path: root/body/fltk-static.adb

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


with

    Ada.Assertions,
    Ada.Containers.Vectors,
    Ada.Unchecked_Conversion,
    Interfaces.C.Strings,
    System.Address_To_Access_Conversions,
    FLTK.Box_Draw_Marshal,
    FLTK.Label_Draw_Marshal,
    FLTK.Static_Callback_Conversions;

use type

    Interfaces.C.int,
    Interfaces.C.Strings.chars_ptr;


package body FLTK.Static is


    package Chk  renames Ada.Assertions;
    package Conv renames FLTK.Static_Callback_Conversions;




    -----------------
    --  Operators  --
    -----------------

    type File_Mode_Bitmask is mod 2 ** Interfaces.C.int'Size;

    function FMode_To_Bits is new
        Ada.Unchecked_Conversion (File_Mode, File_Mode_Bitmask);

    function Bits_To_FMode is new
        Ada.Unchecked_Conversion (File_Mode_Bitmask, File_Mode);


    function "+"
           (Left, Right : in File_Mode)
        return File_Mode is
    begin
        return Bits_To_FMode (FMode_To_Bits (Left) or FMode_To_Bits (Right));
    end "+";


    function "-"
           (Left, Right : in File_Mode)
        return File_Mode is
    begin
        return Bits_To_FMode (FMode_To_Bits (Left) and not FMode_To_Bits (Right));
    end "-";




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

    --  Command Line Arguments  --

    function fl_static_arg
           (C : in     Interfaces.C.int;
            V : in     Storage.Integer_Address;
            I : in out Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_arg, "fl_static_arg");
    pragma Inline (fl_static_arg);

    procedure fl_static_args
           (C : in Interfaces.C.int;
            V : in Storage.Integer_Address);
    pragma Import (C, fl_static_args, "fl_static_args");
    pragma Inline (fl_static_args);

    function fl_static_args2
           (C : in     Interfaces.C.int;
            V : in     Storage.Integer_Address;
            I : in out Interfaces.C.int;
            H : in     Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_args2, "fl_static_args2");
    pragma Inline (fl_static_args2);




    --  Thread Notify  --

    function fl_static_add_awake_handler
           (H, F : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_add_awake_handler, "fl_static_add_awake_handler");
    pragma Inline (fl_static_add_awake_handler);

    function fl_static_get_awake_handler
           (H, F : out Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_get_awake_handler, "fl_static_get_awake_handler");
    pragma Inline (fl_static_get_awake_handler);

    function fl_static_awake2
           (H, F : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_awake2, "fl_static_awake2");
    pragma Inline (fl_static_awake2);

    procedure fl_static_awake
           (M : in Storage.Integer_Address);
    pragma Import (C, fl_static_awake, "fl_static_awake");
    pragma Inline (fl_static_awake);




    --  Pre-Eventloop Callbacks  --

    procedure fl_static_add_check
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_check, "fl_static_add_check");
    pragma Inline (fl_static_add_check);

    function fl_static_has_check
           (H, F : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_has_check, "fl_static_has_check");
    pragma Inline (fl_static_has_check);

    procedure fl_static_remove_check
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_remove_check, "fl_static_remove_check");
    pragma Inline (fl_static_remove_check);




    --  Timer Callbacks  --

    procedure fl_static_add_timeout
           (S    : in Interfaces.C.double;
            H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_timeout, "fl_static_add_timeout");
    pragma Inline (fl_static_add_timeout);

    function fl_static_has_timeout
           (H, F : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_has_timeout, "fl_static_has_timeout");
    pragma Inline (fl_static_has_timeout);

    procedure fl_static_remove_timeout
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_remove_timeout, "fl_static_remove_timeout");
    pragma Inline (fl_static_remove_timeout);

    procedure fl_static_repeat_timeout
           (S    : in Interfaces.C.double;
            H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_repeat_timeout, "fl_static_repeat_timeout");
    pragma Inline (fl_static_repeat_timeout);




    --  Clipboard Callbacks  --

    procedure fl_static_add_clipboard_notify
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_clipboard_notify, "fl_static_add_clipboard_notify");
    pragma Inline (fl_static_add_clipboard_notify);

    procedure fl_static_remove_clipboard_notify
           (H : in Storage.Integer_Address);
    pragma Import (C, fl_static_remove_clipboard_notify, "fl_static_remove_clipboard_notify");
    pragma Inline (fl_static_remove_clipboard_notify);




    --  File Descriptor Waiting Callbacks  --

    procedure fl_static_add_fd
           (D    : in Interfaces.C.int;
            H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_fd, "fl_static_add_fd");
    pragma Inline (fl_static_add_fd);

    procedure fl_static_add_fd2
           (D, M : in Interfaces.C.int;
            H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_fd2, "fl_static_add_fd2");
    pragma Inline (fl_static_add_fd2);

    procedure fl_static_remove_fd
           (D : in Interfaces.C.int);
    pragma Import (C, fl_static_remove_fd, "fl_static_remove_fd");
    pragma Inline (fl_static_remove_fd);

    procedure fl_static_remove_fd2
           (D, M : in Interfaces.C.int);
    pragma Import (C, fl_static_remove_fd2, "fl_static_remove_fd2");
    pragma Inline (fl_static_remove_fd2);




    --  Idle Callbacks  --

    procedure fl_static_add_idle
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_idle, "fl_static_add_idle");
    pragma Inline (fl_static_add_idle);

    function fl_static_has_idle
           (H, F : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_has_idle, "fl_static_has_idle");
    pragma Inline (fl_static_has_idle);

    procedure fl_static_remove_idle
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_remove_idle, "fl_static_remove_idle");
    pragma Inline (fl_static_remove_idle);




    --  System Events  --

    procedure fl_static_add_system_handler
           (H, F : in Storage.Integer_Address);
    pragma Import (C, fl_static_add_system_handler, "fl_static_add_system_handler");
    pragma Inline (fl_static_add_system_handler);




    --  Custom Colors  --

    function fl_static_get_color2
           (C : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_static_get_color2, "fl_static_get_color2");
    pragma Inline (fl_static_get_color2);

    procedure fl_static_get_color
           (C       : in     Interfaces.C.unsigned;
            R, G, B :    out Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_get_color, "fl_static_get_color");
    pragma Inline (fl_static_get_color);

    procedure fl_static_set_color2
           (T, F : in Interfaces.C.unsigned);
    pragma Import (C, fl_static_set_color2, "fl_static_set_color2");
    pragma Inline (fl_static_set_color2);

    procedure fl_static_set_color
           (C       : in Interfaces.C.unsigned;
            R, G, B : in Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_set_color, "fl_static_set_color");
    pragma Inline (fl_static_set_color);

    procedure fl_static_free_color
           (C : in Interfaces.C.unsigned;
            B : in Interfaces.C.int);
    pragma Import (C, fl_static_free_color, "fl_static_free_color");
    pragma Inline (fl_static_free_color);

    function fl_static_get_box_color
           (T : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_static_get_box_color, "fl_static_get_box_color");
    pragma Inline (fl_static_get_box_color);

    procedure fl_static_set_box_color
           (T : in Interfaces.C.unsigned);
    pragma Import (C, fl_static_set_box_color, "fl_static_set_box_color");
    pragma Inline (fl_static_set_box_color);

    procedure fl_static_foreground
           (R, G, B : in Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_foreground, "fl_static_foreground");
    pragma Inline (fl_static_foreground);

    procedure fl_static_background
           (R, G, B : in Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_background, "fl_static_background");
    pragma Inline (fl_static_background);

    procedure fl_static_background2
           (R, G, B : in Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_background2, "fl_static_background2");
    pragma Inline (fl_static_background2);




    --  Custom Fonts  --

    function fl_static_get_font
           (K : in Interfaces.C.int)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, fl_static_get_font, "fl_static_get_font");
    pragma Inline (fl_static_get_font);

    function fl_static_get_font_name
           (K : in Interfaces.C.int)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, fl_static_get_font_name, "fl_static_get_font_name");
    pragma Inline (fl_static_get_font_name);

    procedure fl_static_set_font
           (T, F : in Interfaces.C.int);
    pragma Import (C, fl_static_set_font, "fl_static_set_font");
    pragma Inline (fl_static_set_font);

    procedure fl_static_set_font2
           (T : in Interfaces.C.int;
            S : in Interfaces.C.Strings.chars_ptr);
    pragma Import (C, fl_static_set_font2, "fl_static_set_font2");
    pragma Inline (fl_static_set_font2);

    function fl_static_get_font_sizes
           (F : in     Interfaces.C.int;
            A :    out Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_static_get_font_sizes, "fl_static_get_font_sizes");
    pragma Inline (fl_static_get_font_sizes);

    function fl_static_font_size_array_get
           (A : in Storage.Integer_Address;
            I : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_font_size_array_get, "fl_static_font_size_array_get");
    pragma Inline (fl_static_font_size_array_get);

    function fl_static_set_fonts
        return Interfaces.C.int;
    pragma Import (C, fl_static_set_fonts, "fl_static_set_fonts");
    pragma Inline (fl_static_set_fonts);




    --  Box_Kind Attributes  --

    function fl_static_box_dh
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_box_dh, "fl_static_box_dh");
    pragma Inline (fl_static_box_dh);

    function fl_static_box_dw
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_box_dw, "fl_static_box_dw");
    pragma Inline (fl_static_box_dw);

    function fl_static_box_dx
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_box_dx, "fl_static_box_dx");
    pragma Inline (fl_static_box_dx);

    function fl_static_box_dy
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_box_dy, "fl_static_box_dy");
    pragma Inline (fl_static_box_dy);

    function fl_static_get_boxtype
           (T : in Interfaces.C.int)
        return Storage.Integer_Address;
    pragma Import (C, fl_static_get_boxtype, "fl_static_get_boxtype");
    pragma Inline (fl_static_get_boxtype);

    procedure fl_static_set_boxtype
           (T, F : in Interfaces.C.int);
    pragma Import (C, fl_static_set_boxtype, "fl_static_set_boxtype");
    pragma Inline (fl_static_set_boxtype);

    procedure fl_static_set_boxtype2
           (T              : in Interfaces.C.int;
            F              : in Storage.Integer_Address;
            DX, DY, DW, DH : in Interfaces.C.unsigned_char);
    pragma Import (C, fl_static_set_boxtype2, "fl_static_set_boxtype2");
    pragma Inline (fl_static_set_boxtype2);

    function fl_static_draw_box_active
        return Interfaces.C.int;
    pragma Import (C, fl_static_draw_box_active, "fl_static_draw_box_active");
    pragma Inline (fl_static_draw_box_active);




    --  Label_Kind Attributes  --

    procedure fl_static_set_labeltype
           (K    : in Interfaces.C.int;
            D, M : in Storage.Integer_Address);
    pragma Import (C, fl_static_set_labeltype, "fl_static_set_labeltype");
    pragma Inline (fl_static_set_labeltype);




    --  Clipboard / Selection  --

    procedure fl_static_copy
           (T    : in Interfaces.C.char_array;
            L, K : in Interfaces.C.int);
    pragma Import (C, fl_static_copy, "fl_static_copy");
    pragma Inline (fl_static_copy);

    procedure fl_static_paste
           (R : in Storage.Integer_Address;
            S : in Interfaces.C.int);
    pragma Import (C, fl_static_paste, "fl_static_paste");
    pragma Inline (fl_static_paste);

    procedure fl_static_selection
           (O : in Storage.Integer_Address;
            T : in Interfaces.C.char_array;
            L : in Interfaces.C.int);
    pragma Import (C, fl_static_selection, "fl_static_selection");
    pragma Inline (fl_static_selection);

    function fl_static_clipboard_contains
           (K : in Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, fl_static_clipboard_contains, "fl_static_clipboard_contains");
    pragma Inline (fl_static_clipboard_contains);




    --  Dragon Drop  --

    function fl_static_dnd
        return Interfaces.C.int;
    pragma Import (C, fl_static_dnd, "fl_static_dnd");
    pragma Inline (fl_static_dnd);

    function fl_static_get_dnd_text_ops
        return Interfaces.C.int;
    pragma Import (C, fl_static_get_dnd_text_ops, "fl_static_get_dnd_text_ops");
    pragma Inline (fl_static_get_dnd_text_ops);

    procedure fl_static_set_dnd_text_ops
           (T : in Interfaces.C.int);
    pragma Import (C, fl_static_set_dnd_text_ops, "fl_static_set_dnd_text_ops");
    pragma Inline (fl_static_set_dnd_text_ops);




    --  Windows  --

    procedure fl_static_default_atclose
           (W, U : in Storage.Integer_Address);
    pragma Import (C, fl_static_default_atclose, "fl_static_default_atclose");
    pragma Inline (fl_static_default_atclose);

    function fl_static_get_first_window
        return Storage.Integer_Address;
    pragma Import (C, fl_static_get_first_window, "fl_static_get_first_window");
    pragma Inline (fl_static_get_first_window);

    procedure fl_static_set_first_window
           (T : in Storage.Integer_Address);
    pragma Import (C, fl_static_set_first_window, "fl_static_set_first_window");
    pragma Inline (fl_static_set_first_window);

    function fl_static_next_window
           (W : in Storage.Integer_Address)
        return Storage.Integer_Address;
    pragma Import (C, fl_static_next_window, "fl_static_next_window");
    pragma Inline (fl_static_next_window);

    function fl_static_modal
        return Storage.Integer_Address;
    pragma Import (C, fl_static_modal, "fl_static_modal");
    pragma Inline (fl_static_modal);




    --  Queue  --

    function fl_static_readqueue
        return Storage.Integer_Address;
    pragma Import (C, fl_static_readqueue, "fl_static_readqueue");
    pragma Inline (fl_static_readqueue);




    --  Schemes  --

    function fl_static_get_scheme
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, fl_static_get_scheme, "fl_static_get_scheme");
    pragma Inline (fl_static_get_scheme);

    procedure fl_static_set_scheme
           (S : in Interfaces.C.char_array);
    pragma Import (C, fl_static_set_scheme, "fl_static_set_scheme");
    pragma Inline (fl_static_set_scheme);

    function fl_static_is_scheme
           (S : in Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, fl_static_is_scheme, "fl_static_is_scheme");
    pragma Inline (fl_static_is_scheme);




    --  Library Options  --

    function fl_static_get_option
           (O : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_static_get_option, "fl_static_get_option");
    pragma Inline (fl_static_get_option);

    procedure fl_static_set_option
           (O, T : in Interfaces.C.int);
    pragma Import (C, fl_static_set_option, "fl_static_set_option");
    pragma Inline (fl_static_set_option);




    --  Scrollbars  --

    function fl_static_get_scrollbar_size
        return Interfaces.C.int;
    pragma Import (C, fl_static_get_scrollbar_size, "fl_static_get_scrollbar_size");
    pragma Inline (fl_static_get_scrollbar_size);

    procedure fl_static_set_scrollbar_size
           (S : in Interfaces.C.int);
    pragma Import (C, fl_static_set_scrollbar_size, "fl_static_set_scrollbar_size");
    pragma Inline (fl_static_set_scrollbar_size);




    --  User Data  --

    package Widget_Convert is new System.Address_To_Access_Conversions
        (FLTK.Widgets.Widget'Class);
    package Window_Convert is new System.Address_To_Access_Conversions
        (FLTK.Widgets.Groups.Windows.Window'Class);

    function fl_widget_get_user_data
           (W : in Storage.Integer_Address)
        return Storage.Integer_Address;
    pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data");




    ----------------------
    --  Callback Hooks  --
    ----------------------

    Current_Args_Handler : Args_Handler;

    function Args_Hook
           (C : in     Interfaces.C.int;
            V : in     Storage.Integer_Address;
            I : in out Interfaces.C.int)
        return Interfaces.C.int;
    pragma Convention (C, Args_Hook);

    function Args_Hook
           (C : in     Interfaces.C.int;
            V : in     Storage.Integer_Address;
            I : in out Interfaces.C.int)
        return Interfaces.C.int
    is
        Result : Natural;
    begin
        Result := Current_Args_Handler (Positive (I));
        I := I + Interfaces.C.int (Result);
        return Interfaces.C.int (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "Args_Handler callback was supplied unexpected int i value of " &
        Interfaces.C.int'Image (I);
    end Args_Hook;


    procedure Awake_Hook
           (U : in Storage.Integer_Address);
    pragma Convention (C, Awake_Hook);

    procedure Awake_Hook
           (U : in Storage.Integer_Address) is
    begin
        if U /= Null_Pointer then
            Conv.To_Awake_Access (U).all;
        end if;
    end Awake_Hook;


    procedure Timeout_Hook
           (U : in Storage.Integer_Address);
    pragma Convention (C, Timeout_Hook);

    procedure Timeout_Hook
           (U : in Storage.Integer_Address) is
    begin
        Conv.To_Timeout_Access (U).all;
    end Timeout_Hook;


    --  This is handled on the Ada side because otherwise there would be
    --  no way to specify which callback to remove in FLTK once one was
    --  added. This is because Fl::remove_clipboard_notify does not pay
    --  attention to the void * data. This hook is passed during package init.
    package Clipboard_Notify_Vectors is new Ada.Containers.Vectors
       (Index_Type   => Positive,
        Element_Type => Clipboard_Notify_Handler);

    Current_Clip_Notes : Clipboard_Notify_Vectors.Vector;

    procedure Clipboard_Notify_Hook
           (S : in Interfaces.C.int;
            U : in Storage.Integer_Address);
    pragma Convention (C, Clipboard_Notify_Hook);

    procedure Clipboard_Notify_Hook
           (S : in Interfaces.C.int;
            U : in Storage.Integer_Address) is
    begin
        pragma Assert (S in
            Buffer_Kind'Pos (Buffer_Kind'First) .. Buffer_Kind'Pos (Buffer_Kind'Last));
        for Call of Current_Clip_Notes loop
            Call.all (Buffer_Kind'Val (S));
        end loop;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Clipboard_Notify_Hook was passed unexpected Buffer_Kind int value of " &
        Interfaces.C.int'Image (S);
    end Clipboard_Notify_Hook;


    procedure FD_Hook
           (FD : in Interfaces.C.int;
            U  : in Storage.Integer_Address);
    pragma Convention (C, FD_Hook);

    procedure FD_Hook
           (FD : in Interfaces.C.int;
            U  : in Storage.Integer_Address) is
    begin
        Conv.To_File_Access (U).all (File_Descriptor (FD));
    end FD_Hook;


    procedure Idle_Hook
           (U : in Storage.Integer_Address);
    pragma Convention (C, Idle_Hook);

    procedure Idle_Hook
           (U : in Storage.Integer_Address) is
    begin
        Conv.To_Idle_Access (U).all;
    end Idle_Hook;




    -------------------
    --  Destructors  --
    -------------------

    procedure Finalize
           (This : in out FLTK_Static_Final_Controller) is
    begin
        FLTK.Args_Marshal.Free_Argv (The_Argv);
        for Override of Font_Overrides loop
            Interfaces.C.Strings.Free (Override);
        end loop;
        fl_static_remove_clipboard_notify (Storage.To_Integer (Clipboard_Notify_Hook'Address));
    end Finalize;




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

    --  Command Line Arguments  --

    function Parse_Arg
           (Index : in Positive)
        return Natural
    is
        Count : Interfaces.C.int := Interfaces.C.int (Index);
    begin
        return Natural (fl_static_arg
           (The_Argv'Length,
            Storage.To_Integer (The_Argv (The_Argv'First)'Address),
            Count));
    end Parse_Arg;


    procedure Parse_Args is
    begin
        fl_static_args (The_Argv'Length, Storage.To_Integer (The_Argv (The_Argv'First)'Address));
    end Parse_Args;


    procedure Parse_Args
           (Count :    out Natural;
            Func  : in     Args_Handler := null)
    is
        My_Count : Interfaces.C.int := 1;
        Result   : Interfaces.C.int;
    begin
        Current_Args_Handler := Func;
        Result := fl_static_args2
           (The_Argv'Length,
            Storage.To_Integer (The_Argv (The_Argv'First)'Address),
            My_Count,
            (if Func = null then Null_Pointer else Storage.To_Integer (Args_Hook'Address)));
        Count := Integer (My_Count) - 1;
        if Result = 0 then
            raise Argument_Error with
                "Fl::args could not recognise switch at argument number " &
                Interfaces.C.int'Image (My_Count);
        else
            pragma Assert (Result > 0);
        end if;
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "Fl::args produced unexpected i parameter of " & Interfaces.C.int'Image (My_Count);
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Fl::args returned unexpected int value of " & Interfaces.C.int'Image (Result);
    end Parse_Args;




    --  Thread Notify  --

    procedure Add_Awake_Handler
           (Func : in Awake_Handler)
    is
        Result : Interfaces.C.int := fl_static_add_awake_handler
           (Storage.To_Integer (Awake_Hook'Address),
            Conv.To_Address (Func));
    begin
        pragma Assert (Result = 0);
    exception
    when Chk.Assertion_Error =>
        if Result = -1 then
            raise Tasking_Error with
                "Fl::add_awake_handler_ failed to register Awake_Handler callback";
        else
            raise Internal_FLTK_Error with
                "Fl::add_awake_handler_ returned unexpected int value of " &
                Interfaces.C.int'Image (Result);
        end if;
    end Add_Awake_Handler;


    function Get_Awake_Handler
        return Awake_Handler
    is
        Hook, Func : Storage.Integer_Address;
        Result : Interfaces.C.int := fl_static_get_awake_handler (Hook, Func);
    begin
        pragma Assert (Result = 0);
        return Conv.To_Awake_Access (Func);
    exception
    when Chk.Assertion_Error =>
        if Result = -1 then
            raise Tasking_Error with
                "Fl::get_awake_handler_ invoked without prior awake setup";
        else
            raise Internal_FLTK_Error with
                "Fl::get_awake_handler_ returned unexpected int value of " &
                Interfaces.C.int'Image (Result);
        end if;
    end Get_Awake_Handler;


    procedure Awake
           (Func : in Awake_Handler)
    is
        Result : Interfaces.C.int := fl_static_awake2
           (Storage.To_Integer (Awake_Hook'Address),
            Conv.To_Address (Func));
    begin
        pragma Assert (Result = 0);
    exception
    when Chk.Assertion_Error =>
        if Result = -1 then
            raise Tasking_Error with "Fl::awake failed to register Awake_Handler callback";
        else
            raise Internal_FLTK_Error with "Fl::awake returned unexpected int value of " &
                Interfaces.C.int'Image (Result);
        end if;
    end Awake;


    procedure Awake is
    begin
        fl_static_awake (Null_Pointer);
    end Awake;




    --  Pre-Eventloop Callbacks  --

    procedure Add_Check
           (Func : in not null Timeout_Handler) is
    begin
        fl_static_add_check
           (Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func)));
    end Add_Check;


    function Has_Check
           (Func : in not null Timeout_Handler)
        return Boolean is
    begin
        return fl_static_has_check
           (Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func))) /= 0;
    end Has_Check;


    procedure Remove_Check
           (Func : in not null Timeout_Handler) is
    begin
        fl_static_remove_check
           (Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func)));
    end Remove_Check;




    --  Timer Callbacks  --

    procedure Add_Timeout
           (Seconds : in          Long_Float;
            Func    : in not null Timeout_Handler) is
    begin
        fl_static_add_timeout
           (Interfaces.C.double (Seconds),
            Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func)));
    end Add_Timeout;


    function Has_Timeout
           (Func : in not null Timeout_Handler)
        return Boolean is
    begin
        return fl_static_has_timeout
           (Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func))) /= 0;
    end Has_Timeout;


    procedure Remove_Timeout
           (Func : in not null Timeout_Handler) is
    begin
        fl_static_remove_timeout
           (Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func)));
    end Remove_Timeout;


    procedure Repeat_Timeout
           (Seconds : in          Long_Float;
            Func    : in not null Timeout_Handler) is
    begin
        fl_static_repeat_timeout
           (Interfaces.C.double (Seconds),
            Storage.To_Integer (Timeout_Hook'Address),
            Conv.To_Address (Timeout_Handler'(Func)));
    end Repeat_Timeout;




    --  Clipboard Callbacks  --

    procedure Add_Clipboard_Notify
           (Func : in not null Clipboard_Notify_Handler) is
    begin
        Current_Clip_Notes.Append (Func);
    end Add_Clipboard_Notify;


    procedure Remove_Clipboard_Notify
           (Func : in not null Clipboard_Notify_Handler) is
    begin
        for Index in reverse Current_Clip_Notes.First_Index .. Current_Clip_Notes.Last_Index loop
            if Current_Clip_Notes (Index) = Func then
                Current_Clip_Notes.Delete (Index);
                return;
            end if;
        end loop;
    end Remove_Clipboard_Notify;




    --  File Descriptor Waiting Callbacks  --

    procedure Add_File_Descriptor
           (FD   : in          File_Descriptor;
            Func : in not null File_Handler) is
    begin
        fl_static_add_fd
           (Interfaces.C.int (FD),
            Storage.To_Integer (FD_Hook'Address),
            Conv.To_Address (Func));
    end Add_File_Descriptor;


    procedure Add_File_Descriptor
           (FD   : in          File_Descriptor;
            Mode : in          File_Mode;
            Func : in not null File_Handler) is
    begin
        fl_static_add_fd2
           (Interfaces.C.int (FD),
            FMode_To_Cint (Mode),
            Storage.To_Integer (FD_Hook'Address),
            Conv.To_Address (Func));
    end Add_File_Descriptor;


    procedure Remove_File_Descriptor
           (FD : in File_Descriptor) is
    begin
        fl_static_remove_fd (Interfaces.C.int (FD));
    end Remove_File_Descriptor;


    procedure Remove_File_Descriptor
           (FD   : in File_Descriptor;
            Mode : in File_Mode) is
    begin
        fl_static_remove_fd2 (Interfaces.C.int (FD), FMode_To_Cint (Mode));
    end Remove_File_Descriptor;




    --  Idle Callbacks  --

    procedure Add_Idle
           (Func : in not null Idle_Handler) is
    begin
        fl_static_add_idle
           (Storage.To_Integer (Idle_Hook'Address),
            Conv.To_Address (Idle_Handler'(Func)));
    end Add_Idle;


    function Has_Idle
           (Func : in not null Idle_Handler)
        return Boolean is
    begin
        return fl_static_has_idle
           (Storage.To_Integer (Idle_Hook'Address),
            Conv.To_Address (Idle_Handler'(Func))) /= 0;
    end Has_Idle;


    procedure Remove_Idle
           (Func : in not null Idle_Handler) is
    begin
        fl_static_remove_idle
           (Storage.To_Integer (Idle_Hook'Address),
            Conv.To_Address (Idle_Handler'(Func)));
    end Remove_Idle;




    --  Custom Colors  --

    function Get_Color
           (From : in Color)
        return Color is
    begin
        return Color (fl_static_get_color2 (Interfaces.C.unsigned (From)));
    end Get_Color;


    procedure Get_Color
           (From    : in     Color;
            R, G, B :    out Color_Component) is
    begin
        fl_static_get_color
           (Interfaces.C.unsigned (From),
            Interfaces.C.unsigned_char (R),
            Interfaces.C.unsigned_char (G),
            Interfaces.C.unsigned_char (B));
    end Get_Color;


    procedure Set_Color
           (Target, Source : in Color) is
    begin
        fl_static_set_color2
           (Interfaces.C.unsigned (Target),
            Interfaces.C.unsigned (Source));
    end Set_Color;


    procedure Set_Color
           (Target  : in Color;
            R, G, B : in Color_Component) is
    begin
        fl_static_set_color
           (Interfaces.C.unsigned (Target),
            Interfaces.C.unsigned_char (R),
            Interfaces.C.unsigned_char (G),
            Interfaces.C.unsigned_char (B));
    end Set_Color;


    procedure Free_Color
           (Value   : in Color;
            Overlay : in Boolean := False) is
    begin
        fl_static_free_color
           (Interfaces.C.unsigned (Value),
            Boolean'Pos (Overlay));
    end Free_Color;


    function Get_Box_Color
           (Tone : in Color)
        return Color is
    begin
        return Color (fl_static_get_box_color (Interfaces.C.unsigned (Tone)));
    end Get_Box_Color;


    procedure Set_Box_Color
           (Tone : in Color) is
    begin
        fl_static_set_box_color (Interfaces.C.unsigned (Tone));
    end Set_Box_Color;


    procedure Set_Foreground
           (R, G, B : in Color_Component) is
    begin
        fl_static_foreground
           (Interfaces.C.unsigned_char (R),
            Interfaces.C.unsigned_char (G),
            Interfaces.C.unsigned_char (B));
    end Set_Foreground;


    procedure Set_Background
           (R, G, B : in Color_Component) is
    begin
        fl_static_background
           (Interfaces.C.unsigned_char (R),
            Interfaces.C.unsigned_char (G),
            Interfaces.C.unsigned_char (B));
    end Set_Background;


    procedure Set_Alt_Background
           (R, G, B : in Color_Component) is
    begin
        fl_static_background2
           (Interfaces.C.unsigned_char (R),
            Interfaces.C.unsigned_char (G),
            Interfaces.C.unsigned_char (B));
    end Set_Alt_Background;




    --  Custom Fonts  --

    function Font_Image
           (Kind : in Font_Kind)
        return String is
    begin
        --  should never get a null string in return since it's from an enum
        return Interfaces.C.Strings.Value (fl_static_get_font (Font_Kind'Pos (Kind)));
    end Font_Image;


    function Font_Family_Image
           (Kind : in Font_Kind)
        return String is
    begin
        --  should never get a null string in return since it's from an enum
        return Interfaces.C.Strings.Value (fl_static_get_font_name (Font_Kind'Pos (Kind)));
    end Font_Family_Image;


    procedure Set_Font_Kind
           (Target, Source : in Font_Kind) is
    begin
        fl_static_set_font (Font_Kind'Pos (Target), Font_Kind'Pos (Source));
    end Set_Font_Kind;


    procedure Set_Font_Kind
           (Target : in Font_Kind;
            Source : in String) is
    begin
        Interfaces.C.Strings.Free (Font_Overrides (Target));
        Font_Overrides (Target) := Interfaces.C.Strings.New_String (Source);
        fl_static_set_font2 (Font_Kind'Pos (Target), Font_Overrides (Target));
    end Set_Font_Kind;


    function Font_Sizes
           (Kind : in Font_Kind)
        return Font_Size_Array
    is
        Ptr : Storage.Integer_Address;
        Arr : Font_Size_Array
            (1 .. Integer (fl_static_get_font_sizes (Font_Kind'Pos (Kind), Ptr)));
    begin
        --  This array copying avoids any worry that the static buffer will be overwritten.
        for I in 1 .. Arr'Length loop
            Arr (I) := Font_Size (fl_static_font_size_array_get (Ptr, Interfaces.C.int (I)));
        end loop;
        return Arr;
    end Font_Sizes;


    procedure Setup_Fonts
           (How_Many_Set_Up : out Natural)
    is
        Result : Interfaces.C.int := fl_static_set_fonts;
    begin
        How_Many_Set_Up := Natural (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "Fl::set_fonts returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Setup_Fonts;




    --  Box_Kind Attributes  --

    function Get_Box_Height_Offset
           (Kind : in Box_Kind)
        return Integer is
    begin
        return Integer (fl_static_box_dh (Box_Kind'Pos (Kind)));
    end Get_Box_Height_Offset;


    function Get_Box_Width_Offset
           (Kind : in Box_Kind)
        return Integer is
    begin
        return Integer (fl_static_box_dw (Box_Kind'Pos (Kind)));
    end Get_Box_Width_Offset;


    function Get_Box_X_Offset
           (Kind : in Box_Kind)
        return Integer is
    begin
        return Integer (fl_static_box_dx (Box_Kind'Pos (Kind)));
    end Get_Box_X_Offset;


    function Get_Box_Y_Offset
           (Kind : in Box_Kind)
        return Integer is
    begin
        return Integer (fl_static_box_dy (Box_Kind'Pos (Kind)));
    end Get_Box_Y_Offset;


    procedure Set_Box_Kind
           (To, From : in Box_Kind) is
    begin
        fl_static_set_boxtype (Box_Kind'Pos (To), Box_Kind'Pos (From));
    end Set_Box_Kind;


    function Draw_Box_Active
        return Boolean is
    begin
        return fl_static_draw_box_active /= 0;
    end Draw_Box_Active;


    function Get_Box_Draw_Function
           (Kind : in Box_Kind)
        return Box_Draw_Function is
    begin
        return FLTK.Box_Draw_Marshal.To_Ada (Kind, fl_static_get_boxtype (Box_Kind'Pos (Kind)));
    end Get_Box_Draw_Function;


    procedure Set_Box_Draw_Function
           (Kind               : in Box_Kind;
            Func               : in Box_Draw_Function;
            Offset_X, Offset_Y : in Byte_Integer := 0;
            Offset_W, Offset_H : in Byte_Integer := 0) is
    begin
        fl_static_set_boxtype2
           (Box_Kind'Pos (Kind),
            FLTK.Box_Draw_Marshal.To_C (Kind, Func),
            Interfaces.C.unsigned_char (Offset_X),
            Interfaces.C.unsigned_char (Offset_Y),
            Interfaces.C.unsigned_char (Offset_W),
            Interfaces.C.unsigned_char (Offset_H));
    end Set_Box_Draw_Function;




    --  Label_Kind Attributes  --

    procedure Set_Label_Kind
           (Target, Source : in Label_Kind) is
    begin
        --  As of FLTK 1.3.11 there is no definition given for this function
        --  so this is null to avoid linker errors.
        null;
    end Set_Label_Kind;


    procedure Set_Label_Draw_Function
           (Kind         : in Label_Kind;
            Draw_Func    : in Label_Draw_Function;
            Measure_Func : in Label_Measure_Function) is
    begin
        fl_static_set_labeltype
           (Label_Kind'Pos (Kind),
            FLTK.Label_Draw_Marshal.To_C (Kind, Draw_Func),
            FLTK.Label_Draw_Marshal.To_C (Kind, Measure_Func));
    end Set_Label_Draw_Function;




    --  Clipboard / Selection  --

    procedure Copy
           (Text : in String;
            Dest : in Buffer_Kind) is
    begin
        fl_static_copy
           (Interfaces.C.To_C (Text),
            Text'Length,
            Buffer_Kind'Pos (Dest));
    end Copy;


    procedure Paste
           (Receiver : in FLTK.Widgets.Widget'Class;
            Source   : in Buffer_Kind) is
    begin
        fl_static_paste
           (Wrapper (Receiver).Void_Ptr,
            Buffer_Kind'Pos (Source));
    end Paste;


    procedure Selection
           (Owner : in FLTK.Widgets.Widget'Class;
            Text  : in String) is
    begin
        fl_static_selection
           (Wrapper (Owner).Void_Ptr,
            Interfaces.C.To_C (Text),
            Text'Length);
    end Selection;


    function Clipboard_Contains
           (Kind : in String)
        return Boolean is
    begin
        return fl_static_clipboard_contains (Interfaces.C.To_C (Kind)) /= 0;
    end Clipboard_Contains;




    --  Dragon Drop  --

    procedure Drag_Drop_Start is
        Ignore : Interfaces.C.int := fl_static_dnd;
    begin
        null;
    end Drag_Drop_Start;


    function Get_Drag_Drop_Text_Support
        return Boolean is
    begin
        return fl_static_get_dnd_text_ops /= 0;
    end Get_Drag_Drop_Text_Support;


    procedure Set_Drag_Drop_Text_Support
           (To : in Boolean) is
    begin
        fl_static_set_dnd_text_ops (Boolean'Pos (To));
    end Set_Drag_Drop_Text_Support;




    --  Windows  --

    procedure Default_Window_Close
           (Item : in out FLTK.Widgets.Widget'Class) is
    begin
        pragma Assert (Wrapper (Item).Void_Ptr /= Null_Pointer);
        fl_static_default_atclose
           (Wrapper (Item).Void_Ptr,
            fl_widget_get_user_data (Wrapper (Item).Void_Ptr));
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Fl::default_atclose received uninitialised widget";
    end Default_Window_Close;


    function Get_First_Window
        return access FLTK.Widgets.Groups.Windows.Window'Class
    is
        First_Ptr : Storage.Integer_Address := fl_static_get_first_window;
        Actual_First : access FLTK.Widgets.Groups.Windows.Window'Class;
    begin
        if First_Ptr /= Null_Pointer then
            First_Ptr := fl_widget_get_user_data (First_Ptr);
            pragma Assert (First_Ptr /= Null_Pointer);
            Actual_First := Window_Convert.To_Pointer (Storage.To_Address (First_Ptr));
        end if;
        return Actual_First;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Widget returned by Fl::first_window did not have user_data reference back to Ada";
    end Get_First_Window;


    procedure Set_First_Window
           (To : in FLTK.Widgets.Groups.Windows.Window'Class) is
    begin
        fl_static_set_first_window (Wrapper (To).Void_Ptr);
    end Set_First_Window;


    function Get_Next_Window
           (From : in FLTK.Widgets.Groups.Windows.Window'Class)
        return access FLTK.Widgets.Groups.Windows.Window'Class
    is
        Next_Ptr : Storage.Integer_Address := fl_static_next_window (Wrapper (From).Void_Ptr);
        Actual_Next : access FLTK.Widgets.Groups.Windows.Window'Class;
    begin
        if Next_Ptr /= Null_Pointer then
            Next_Ptr := fl_widget_get_user_data (Next_Ptr);
            pragma Assert (Next_Ptr /= Null_Pointer);
            Actual_Next := Window_Convert.To_Pointer (Storage.To_Address (Next_Ptr));
        end if;
        return Actual_Next;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Widget returned by Fl::next_window did not have user_data reference back to Ada";
    end Get_Next_Window;


    function Get_Top_Modal
        return access FLTK.Widgets.Groups.Windows.Window'Class
    is
        Modal_Ptr : Storage.Integer_Address := fl_static_modal;
        Actual_Modal : access FLTK.Widgets.Groups.Windows.Window'Class;
    begin
        if Modal_Ptr /= Null_Pointer then
            Modal_Ptr := fl_widget_get_user_data (Modal_Ptr);
            pragma Assert (Modal_Ptr /= Null_Pointer);
            Actual_Modal := Window_Convert.To_Pointer (Storage.To_Address (Modal_Ptr));
        end if;
        return Actual_Modal;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Widget returned by Fl::modal did not have user_data reference back to Ada";
    end Get_Top_Modal;




    --  Queue  --

    function Read_Queue
        return access FLTK.Widgets.Widget'Class
    is
        Queue_Ptr : Storage.Integer_Address := fl_static_readqueue;
        Actual_Queue : access FLTK.Widgets.Widget'Class;
    begin
        if Queue_Ptr /= Null_Pointer then
            Queue_Ptr := fl_widget_get_user_data (Queue_Ptr);
            pragma Assert (Queue_Ptr /= Null_Pointer);
            Actual_Queue := Widget_Convert.To_Pointer (Storage.To_Address (Queue_Ptr));
        end if;
        return Actual_Queue;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Widget returned by Fl::readqueue did not have user_data reference back to Ada";
    end Read_Queue;




    --  Schemes  --

    function Get_Scheme
        return String
    is
        Ptr : Interfaces.C.Strings.chars_ptr := fl_static_get_scheme;
    begin
        if Ptr = Interfaces.C.Strings.Null_Ptr then
            return "";
        else
            return Interfaces.C.Strings.Value (Ptr);
        end if;
    end Get_Scheme;


    procedure Set_Scheme
           (To : in String) is
    begin
        --  A copy of the Scheme string is stored in FLTK
        fl_static_set_scheme (Interfaces.C.To_C (To));
    end Set_Scheme;


    function Is_Scheme
           (Scheme : in String)
        return Boolean
    is
        Result : Interfaces.C.int := fl_static_is_scheme (Interfaces.C.To_C (Scheme));
    begin
        return Boolean'Val (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "Fl::is_scheme returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Is_Scheme;




    --  Library Options  --

    function Get_Option
           (Opt : in Option)
        return Boolean is
    begin
        return fl_static_get_option (Option'Pos (Opt)) /= 0;
    end Get_Option;


    procedure Set_Option
           (Opt : in Option;
            To  : in Boolean) is
    begin
        fl_static_set_option (Option'Pos (Opt), Boolean'Pos (To));
    end Set_Option;




    --  Scrollbars  --

    function Get_Default_Scrollbar_Size
        return Natural
    is
        Result : Interfaces.C.int := fl_static_get_scrollbar_size;
    begin
        return Natural (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "Fl::scrollbar_size returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Get_Default_Scrollbar_Size;


    procedure Set_Default_Scrollbar_Size
           (To : in Natural) is
    begin
        fl_static_set_scrollbar_size (Interfaces.C.int (To));
    end Set_Default_Scrollbar_Size;


begin


    fl_static_add_clipboard_notify
        (Storage.To_Integer (Clipboard_Notify_Hook'Address), Null_Pointer);


end FLTK.Static;