diff options
Diffstat (limited to 'spec')
| -rw-r--r-- | spec/fltk-asks.ads | 4 | ||||
| -rw-r--r-- | spec/fltk-draw.ads | 22 | ||||
| -rw-r--r-- | spec/fltk-environment.ads | 1 | ||||
| -rw-r--r-- | spec/fltk-events.ads (renamed from spec/fltk-event.ads) | 144 | ||||
| -rw-r--r-- | spec/fltk-images-bitmaps.ads | 23 | ||||
| -rw-r--r-- | spec/fltk-images-rgb.ads | 22 | ||||
| -rw-r--r-- | spec/fltk-images.ads | 2 | ||||
| -rw-r--r-- | spec/fltk-screen.ads | 47 | ||||
| -rw-r--r-- | spec/fltk-static.ads | 252 | ||||
| -rw-r--r-- | spec/fltk-widgets-groups-windows.ads | 4 | ||||
| -rw-r--r-- | spec/fltk-widgets-inputs.ads | 3 | ||||
| -rw-r--r-- | spec/fltk-widgets-menus-menu_buttons.ads | 4 | ||||
| -rw-r--r-- | spec/fltk-widgets.ads | 99 | ||||
| -rw-r--r-- | spec/fltk.ads | 326 |
14 files changed, 656 insertions, 297 deletions
diff --git a/spec/fltk-asks.ads b/spec/fltk-asks.ads index 75296d3..23e2076 100644 --- a/spec/fltk-asks.ads +++ b/spec/fltk-asks.ads @@ -172,6 +172,10 @@ package FLTK.Asks is (Font : in Font_Kind; Size : in Font_Size); + -- Technically the returned Box should have a parent, but you can't access + -- it for annoying technical reasons relating to how the Choice functions + -- work in C++. You shouldn't be trying to poke at those internals anyway. + -- Just stick to calling subprograms to change stuff about this Box. function Get_Message_Icon return FLTK.Widgets.Boxes.Box_Reference; diff --git a/spec/fltk-draw.ads b/spec/fltk-draw.ads index 950a247..a2c66f3 100644 --- a/spec/fltk-draw.ads +++ b/spec/fltk-draw.ads @@ -252,9 +252,12 @@ package FLTK.Draw is (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 3; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : in Boolean := False; - Flip_Vertical : in Boolean := False); + Flip_Vertical : in Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); procedure Draw_Image (X, Y, W, H : in Integer; @@ -265,9 +268,12 @@ package FLTK.Draw is (X, Y, W, H : in Integer; Data : in Color_Component_Array; Depth : in Positive := 1; - Line_Data : in Natural := 0; + Line_Size : in Natural := 0; Flip_Horizontal : Boolean := False; - Flip_Vertical : Boolean := False); + Flip_Vertical : Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); procedure Draw_Image_Mono (X, Y, W, H : in Integer; @@ -279,7 +285,7 @@ package FLTK.Draw is Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; X, Y : in Integer; - Hue : in Color := Grey0_Color) + Tone : in Color := Grey0_Color) with Pre => Colors'Length = Values.Colors and Pixels'Length (1) = Values.Height and @@ -292,9 +298,9 @@ package FLTK.Draw is Alpha : in Integer := 0) return Color_Component_Array with Post => - (if Alpha = 0 - then Read_Image'Result'Length = W * H * 3 - else Read_Image'Result'Length = W * H * 4); + (if Alpha = 0 + then Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 3 + else Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 4); diff --git a/spec/fltk-environment.ads b/spec/fltk-environment.ads index d4a1322..9ab7f7c 100644 --- a/spec/fltk-environment.ads +++ b/spec/fltk-environment.ads @@ -317,7 +317,6 @@ private pragma Convention (C, Binary_Data); - pragma Pack (Binary_Data); for Binary_Data'Component_Size use Interfaces.C.CHAR_BIT; diff --git a/spec/fltk-event.ads b/spec/fltk-events.ads index e512432..5dbc573 100644 --- a/spec/fltk-event.ads +++ b/spec/fltk-events.ads @@ -6,25 +6,33 @@ with - FLTK.Widgets.Groups.Windows; + FLTK.Widgets.Groups.Windows, + System; private with - Ada.Containers.Vectors, + Ada.Finalization, System.Address_To_Access_Conversions; -package FLTK.Event is +package FLTK.Events is type Event_Handler is access function (Event : in Event_Kind) return Event_Outcome; - -- type Event_Dispatch is access function - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; + type Event_Dispatch is access function + (Event : in Event_Kind; + Win : access FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + type System_Event is new System.Address; + + type System_Handler is access function + (Event : in System_Event) + return Event_Outcome; @@ -32,21 +40,39 @@ package FLTK.Event is -- Handlers -- procedure Add_Handler - (Func : in Event_Handler); + (Func : in not null Event_Handler); procedure Remove_Handler - (Func : in Event_Handler); + (Func : in not null Event_Handler); + + procedure Add_System_Handler + (Func : in not null System_Handler); - -- function Get_Dispatch - -- return Event_Dispatch; + procedure Remove_System_Handler + (Func : in not null System_Handler); - -- procedure Set_Dispatch - -- (Func : in Event_Dispatch); - -- function Default_Dispatch - -- (Event : in Event_Kind; - -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) - -- return Event_Outcome; + + + -- Dispatch -- + + function Get_Dispatch + return Event_Dispatch; + + -- Any Event_Dispatch function set must call Handle + -- if you want the Event to actually be acknowledged. + procedure Set_Dispatch + (Func : in Event_Dispatch); + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; @@ -79,6 +105,23 @@ package FLTK.Event is procedure Set_Focus (To : in FLTK.Widgets.Widget'Class); + function Has_Visible_Focus + return Boolean; + + procedure Set_Visible_Focus + (To : in Boolean); + + + + + -- Clipboard -- + + function Clipboard_Text + return String; + + function Clipboard_Kind + return String; + @@ -96,6 +139,10 @@ package FLTK.Event is function Text_Length return Natural; + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; + @@ -104,9 +151,11 @@ package FLTK.Event is function Last return Event_Kind; + -- Focuses on keyboard modifiers only, not mouse buttons function Last_Modifier return Modifier; + -- Focuses on keyboard modifiers only, not mouse buttons function Last_Modifier (Had : in Modifier) return Boolean; @@ -140,9 +189,18 @@ package FLTK.Event is function Is_Click return Boolean; + procedure Clear_Click; + function Is_Multi_Click return Boolean; + -- Returns the actual number of clicks. + -- So no clicks is 0, a single click is 1, a double click is 2, etc. + function Get_Clicks + return Natural; + + -- Will set the actual number of clicks. + -- This means setting it to 0 will make Is_Click return False. procedure Set_Clicks (To : in Natural); @@ -158,6 +216,19 @@ package FLTK.Event is function Mouse_Right return Boolean; + function Mouse_Back + return Boolean; + + function Mouse_Forward + return Boolean; + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; + function Is_Inside (X, Y, W, H : in Integer) return Boolean; @@ -203,12 +274,7 @@ private (FLTK.Widgets.Groups.Windows.Window'Class); - package Handler_Vectors is new Ada.Containers.Vectors - (Index_Type => Positive, Element_Type => Event_Handler); - - - Handlers : Handler_Vectors.Vector := Handler_Vectors.Empty_Vector; - -- Current_Dispatch : Event_Dispatch := null; + Current_Dispatch : Event_Dispatch := null; function fl_widget_get_user_data @@ -223,9 +289,13 @@ private pragma Inline (Add_Handler); pragma Inline (Remove_Handler); - -- pragma Inline (Get_Dispatch); - -- pragma Inline (Set_Dispatch); - -- pragma Inline (Default_Dispatch); + pragma Inline (Add_System_Handler); + pragma Inline (Remove_System_Handler); + + pragma Inline (Get_Dispatch); + pragma Inline (Set_Dispatch); + pragma Inline (Handle_Dispatch); + pragma Inline (Handle); pragma Inline (Get_Grab); pragma Inline (Set_Grab); @@ -236,11 +306,17 @@ private pragma Inline (Set_Below_Mouse); pragma Inline (Get_Focus); pragma Inline (Set_Focus); + pragma Inline (Has_Visible_Focus); + pragma Inline (Set_Visible_Focus); + + pragma Inline (Clipboard_Text); + pragma Inline (Clipboard_Kind); pragma Inline (Compose); pragma Inline (Compose_Reset); pragma Inline (Text); pragma Inline (Text_Length); + pragma Inline (Test_Shortcut); pragma Inline (Last); pragma Inline (Last_Modifier); @@ -253,12 +329,15 @@ private pragma Inline (Mouse_DY); pragma Inline (Get_Mouse); pragma Inline (Is_Click); + pragma Inline (Clear_Click); pragma Inline (Is_Multi_Click); + pragma Inline (Get_Clicks); pragma Inline (Set_Clicks); - pragma Inline (Last_Button); pragma Inline (Mouse_Left); pragma Inline (Mouse_Middle); pragma Inline (Mouse_Right); + pragma Inline (Mouse_Back); + pragma Inline (Mouse_Forward); pragma Inline (Is_Inside); pragma Inline (Last_Key); @@ -271,6 +350,15 @@ private pragma Inline (Key_Shift); -end FLTK.Event; + -- Needed to deregister the handlers + type FLTK_Events_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Events_Final_Controller); + + Cleanup : FLTK_Events_Final_Controller; + + +end FLTK.Events; diff --git a/spec/fltk-images-bitmaps.ads b/spec/fltk-images-bitmaps.ads index b31885c..9577273 100644 --- a/spec/fltk-images-bitmaps.ads +++ b/spec/fltk-images-bitmaps.ads @@ -15,9 +15,9 @@ package FLTK.Images.Bitmaps is - -- Rounds a number of bits up to the next byte boundary. + -- Calculates the bytes needed to hold a given number of bits. - function To_Next_Byte + function Bytes_Needed (Bits : in Natural) return Natural; @@ -33,7 +33,8 @@ package FLTK.Images.Bitmaps is (Data : in Color_Component_Array; Width, Height : in Natural) return Bitmap - with Pre => Data'Length = To_Next_Byte (Width) * Height; + with Pre => + Data'Length >= Size_Type (Bytes_Needed (Width)) * Size_Type (Height); end Forge; @@ -66,31 +67,31 @@ package FLTK.Images.Bitmaps is function Data_Size (This : in Bitmap) - return Natural; + return Size_Type; function Get_Datum (This : in Bitmap; - Place : in Positive) + Place : in Positive_Size) return Color_Component with Pre => Place <= This.Data_Size; procedure Set_Datum (This : in out Bitmap; - Place : in Positive; + Place : in Positive_Size; Value : in Color_Component) with Pre => Place <= This.Data_Size; function Slice (This : in Bitmap; - Low : in Positive; - High : in Natural) + Low : in Positive_Size; + High : in Size_Type) return Color_Component_Array with Pre => High <= This.Data_Size, - Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); procedure Overwrite (This : in out Bitmap; - Place : in Positive; + Place : in Positive_Size; Values : in Color_Component_Array) with Pre => Place + Values'Length - 1 <= This.Data_Size; @@ -123,7 +124,7 @@ private (This : in out Bitmap); - pragma Inline (To_Next_Byte); + pragma Inline (Bytes_Needed); pragma Inline (Copy); diff --git a/spec/fltk-images-rgb.ads b/spec/fltk-images-rgb.ads index daa31c6..d893cec 100644 --- a/spec/fltk-images-rgb.ads +++ b/spec/fltk-images-rgb.ads @@ -25,10 +25,10 @@ package FLTK.Images.RGB is -- Static Settings -- function Get_Max_Size - return Natural; + return Size_Type; procedure Set_Max_Size - (Value : in Natural); + (Value : in Size_Type); @@ -45,8 +45,8 @@ package FLTK.Images.RGB is Line_Size : in Natural := 0) return RGB_Image with Pre => (if Line_Size = 0 - then Data'Length = Width * Height * Depth - else Data'Length = Line_Size * Height) + then Data'Length >= Size_Type (Width) * Size_Type (Height) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (Height)) and Data'Length <= Get_Max_Size; function Create @@ -98,31 +98,31 @@ package FLTK.Images.RGB is function Data_Size (This : in RGB_Image) - return Natural; + return Size_Type; function Get_Datum (This : in RGB_Image; - Place : in Positive) + Place : in Positive_Size) return Color_Component with Pre => Place <= This.Data_Size; procedure Set_Datum (This : in out RGB_Image; - Place : in Positive; + Place : in Positive_Size; Value : in Color_Component) with Pre => Place <= This.Data_Size; function Slice (This : in RGB_Image; - Low : in Positive; - High : in Natural) + Low : in Positive_Size; + High : in Size_Type) return Color_Component_Array with Pre => High <= This.Data_Size, - Post => Slice'Result'Length = Integer'Max (0, High - Low + 1); + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); procedure Overwrite (This : in out RGB_Image; - Place : in Positive; + Place : in Positive_Size; Values : in Color_Component_Array) with Pre => Place + Values'Length - 1 <= This.Data_Size; diff --git a/spec/fltk-images.ads b/spec/fltk-images.ads index 165c203..6afb788 100644 --- a/spec/fltk-images.ads +++ b/spec/fltk-images.ads @@ -14,8 +14,6 @@ package FLTK.Images is type Scaling_Kind is (Nearest, Bilinear); - type Blend is new Float range 0.0 .. 1.0; - No_Image_Error, File_Access_Error, Format_Error : exception; diff --git a/spec/fltk-screen.ads b/spec/fltk-screen.ads index b7d5521..38db9aa 100644 --- a/spec/fltk-screen.ads +++ b/spec/fltk-screen.ads @@ -7,6 +7,26 @@ package FLTK.Screen is + type Visual_Mode is (RGB, RGB_24bit, Double_Buffer, Double_RGB, Double_RGB_24bit); + + + + + -- Environment -- + + procedure Set_Display_String + (Value : in String); + + procedure Set_Visual_Mode + (Value : in Visual_Mode); + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; + + + + -- Basic Dimensions -- function Get_X @@ -79,9 +99,31 @@ package FLTK.Screen is PX, PY, PW, PH : in Integer); + + + -- Drawing -- + + function Is_Damaged + return Boolean; + + procedure Set_Damaged + (To : in Boolean); + + procedure Flush; + + procedure Redraw; + + private + pragma Import (C, Flush, "fl_screen_flush"); + pragma Import (C, Redraw, "fl_screen_redraw"); + + + pragma Inline (Set_Display_String); + pragma Inline (Set_Visual_Mode); + pragma Inline (Get_X); pragma Inline (Get_Y); pragma Inline (Get_W); @@ -94,6 +136,11 @@ private pragma Inline (Work_Area); pragma Inline (Bounding_Rect); + pragma Inline (Is_Damaged); + pragma Inline (Set_Damaged); + pragma Inline (Flush); + pragma Inline (Redraw); + end FLTK.Screen; diff --git a/spec/fltk-static.ads b/spec/fltk-static.ads index 71d5b3f..4f71244 100644 --- a/spec/fltk-static.ads +++ b/spec/fltk-static.ads @@ -6,22 +6,32 @@ with + FLTK.Labels, FLTK.Widgets.Groups.Windows; private with - Interfaces.C; + Ada.Finalization, + Ada.Unchecked_Conversion, + FLTK.Args_Marshal, + Interfaces.C.Strings; package FLTK.Static is - type Awake_Handler is access procedure; + -- Input is the argument index usable with Ada.Command_Line. + -- Output is how many arguments parsed starting from that index. + type Args_Handler is access function + (Index : in Positive) + return Natural; - type Timeout_Handler is access procedure; + type Awake_Handler is access procedure; type Idle_Handler is access procedure; + type Timeout_Handler is access procedure; + type Buffer_Kind is (Selection, Clipboard); @@ -31,15 +41,38 @@ package FLTK.Static is type File_Descriptor is new Integer; - type File_Mode is (Read, Write, Except); + type File_Mode is record + Read : Boolean := False; + Write : Boolean := False; + Except : Boolean := False; + end record; + + function "+" (Left, Right : in File_Mode) return File_Mode; + function "-" (Left, Right : in File_Mode) return File_Mode; + + Read_Mode : constant File_Mode; + Write_Mode : constant File_Mode; + Except_Mode : constant File_Mode; type File_Handler is access procedure (FD : in File_Descriptor); + subtype Byte_Integer is Integer range 0 .. 255; + type Box_Draw_Function is access procedure (X, Y, W, H : in Integer; - My_Color : in Color); + Tone : in Color); + + + type Label_Draw_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + X, Y, W, H : in Integer; + Position : in Alignment); + + type Label_Measure_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + W, H : out Integer); type Option is @@ -47,13 +80,41 @@ package FLTK.Static is Visible_Focus, DND_Text, Show_Tooltips, - FNFC_Uses_GTK, - Last); + FNFC_Uses_GTK); + + + -- According to docs this should be customisable, + -- but in C++ it is a constant pointer to constant. + Help_Message : constant String; + + + Argument_Error : exception; + + + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural; + + procedure Parse_Args; + + -- Not task safe, but you won't need to call this more than once anyway. + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null); + - -- Interthread Notify -- + + -- Thread Notify -- + + -- Unsure if it is worth actually using this or if mixing tasks, pthreads, + -- and whatever other platforms use causes errors in some unexpected way. + -- Might be better to rely on FLTK.Check, Ada tasking, and Ada protected types. + -- You'll need appropriately declared protected objects to pass messages anyway. procedure Add_Awake_Handler (Func : in Awake_Handler); @@ -61,20 +122,29 @@ package FLTK.Static is function Get_Awake_Handler return Awake_Handler; + procedure Awake + (Func : in Awake_Handler); + + procedure Awake; + + procedure Lock; + + procedure Unlock; + -- Pre-Eventloop Callbacks -- procedure Add_Check - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); function Has_Check - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean; procedure Remove_Check - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); @@ -82,19 +152,19 @@ package FLTK.Static is -- Timer Callbacks -- procedure Add_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); function Has_Timeout - (Func : in Timeout_Handler) + (Func : in not null Timeout_Handler) return Boolean; procedure Remove_Timeout - (Func : in Timeout_Handler); + (Func : in not null Timeout_Handler); procedure Repeat_Timeout - (Seconds : in Long_Float; - Func : in Timeout_Handler); + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); @@ -102,10 +172,10 @@ package FLTK.Static is -- Clipboard Callbacks -- procedure Add_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); + (Func : in not null Clipboard_Notify_Handler); procedure Remove_Clipboard_Notify - (Func : in Clipboard_Notify_Handler); + (Func : in not null Clipboard_Notify_Handler); @@ -113,13 +183,13 @@ package FLTK.Static is -- File Descriptor Waiting Callbacks -- procedure Add_File_Descriptor - (FD : in File_Descriptor; - Func : in File_Handler); + (FD : in File_Descriptor; + Func : in not null File_Handler); procedure Add_File_Descriptor - (FD : in File_Descriptor; - Mode : in File_Mode; - Func : in File_Handler); + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler); procedure Remove_File_Descriptor (FD : in File_Descriptor); @@ -134,32 +204,46 @@ package FLTK.Static is -- Idle Callbacks -- procedure Add_Idle - (Func : in Idle_Handler); + (Func : in not null Idle_Handler); function Has_Idle - (Func : in Idle_Handler) + (Func : in not null Idle_Handler) return Boolean; procedure Remove_Idle - (Func : in Idle_Handler); + (Func : in not null Idle_Handler); -- Custom Colors -- + function Get_Color + (From : in Color) + return Color; + procedure Get_Color (From : in Color; R, G, B : out Color_Component); procedure Set_Color - (To : in Color; + (Target, Source : in Color); + + procedure Set_Color + (Target : in Color; R, G, B : in Color_Component); procedure Free_Color (Value : in Color; Overlay : in Boolean := False); + function Get_Box_Color + (Tone : in Color) + return Color; + + procedure Set_Box_Color + (Tone : in Color); + procedure Own_Colormap; procedure Set_Foreground @@ -187,7 +271,11 @@ package FLTK.Static is return String; procedure Set_Font_Kind - (To, From : in Font_Kind); + (Target, Source : in Font_Kind); + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String); function Font_Sizes (Kind : in Font_Kind) @@ -223,15 +311,28 @@ package FLTK.Static is function Draw_Box_Active return Boolean; - -- function Get_Box_Draw_Function - -- (Kind : in Box_Kind) - -- return Box_Draw_Function; + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return 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); + + + + + -- Label_Kind Attributes -- - -- procedure Set_Box_Draw_Function - -- (Kind : in Box_Kind; - -- Func : in Box_Draw_Function; - -- Offset_X, Offset_Y : in Integer := 0; - -- Offset_W, Offset_H : in Integer := 0); + procedure Set_Label_Kind + (Target, Source : in Label_Kind); + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function); @@ -250,6 +351,10 @@ package FLTK.Static is (Owner : in FLTK.Widgets.Widget'Class; Text : in String); + function Clipboard_Contains + (Kind : in String) + return Boolean; + @@ -266,18 +371,12 @@ package FLTK.Static is - -- Input Focus -- + -- Input Methods -- procedure Enable_System_Input; procedure Disable_System_Input; - function Has_Visible_Focus - return Boolean; - - procedure Set_Visible_Focus - (To : in Boolean); - @@ -307,8 +406,6 @@ package FLTK.Static is function Read_Queue return access FLTK.Widgets.Widget'Class; - procedure Do_Widget_Deletion; - @@ -354,25 +451,54 @@ package FLTK.Static is private - File_Mode_Codes : array (File_Mode) of Interfaces.C.int := - (Read => 1, Write => 4, Except => 8); + The_Argv : Interfaces.C.Strings.chars_ptr_array := FLTK.Args_Marshal.Create_Argv; + + for File_Mode use record + Read at 0 range 0 .. 0; + -- bit position 1 is unused + Write at 0 range 2 .. 2; + Except at 0 range 3 .. 3; + end record; + + for File_Mode'Size use Interfaces.C.int'Size; + + Read_Mode : constant File_Mode := (Read => True, others => False); + Write_Mode : constant File_Mode := (Write => True, others => False); + Except_Mode : constant File_Mode := (Except => True, others => False); + + function FMode_To_Cint is new + Ada.Unchecked_Conversion (File_Mode, Interfaces.C.int); + + + help_usage_string_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, help_usage_string_ptr, "fl_help_usage_string_ptr"); + + Help_Message : constant String := Interfaces.C.Strings.Value (help_usage_string_ptr); + + + Font_Overrides : array (Font_Kind) of Interfaces.C.Strings.chars_ptr; + + + pragma Import (C, Lock, "fl_static_lock"); + pragma Import (C, Unlock, "fl_static_unlock"); pragma Import (C, Own_Colormap, "fl_static_own_colormap"); pragma Import (C, System_Colors, "fl_static_get_system_colors"); - pragma Import (C, Drag_Drop_Start, "fl_static_dnd"); - pragma Import (C, Enable_System_Input, "fl_static_enable_im"); pragma Import (C, Disable_System_Input, "fl_static_disable_im"); - pragma Import (C, Do_Widget_Deletion, "fl_static_do_widget_deletion"); - pragma Import (C, Reload_Scheme, "fl_static_reload_scheme"); + pragma Inline (Parse_Arg); + pragma Inline (Add_Awake_Handler); pragma Inline (Get_Awake_Handler); + pragma Inline (Awake); + pragma Inline (Lock); + pragma Inline (Unlock); pragma Inline (Add_Check); pragma Inline (Has_Check); @@ -396,6 +522,8 @@ private pragma Inline (Get_Color); pragma Inline (Set_Color); pragma Inline (Free_Color); + pragma Inline (Get_Box_Color); + pragma Inline (Set_Box_Color); pragma Inline (Own_Colormap); pragma Inline (Set_Foreground); pragma Inline (Set_Background); @@ -414,12 +542,16 @@ private pragma Inline (Get_Box_Y_Offset); pragma Inline (Set_Box_Kind); pragma Inline (Draw_Box_Active); - -- pragma Inline (Get_Box_Draw_Function); - -- pragma Inline (Set_Box_Draw_Function); + pragma Inline (Get_Box_Draw_Function); + pragma Inline (Set_Box_Draw_Function); + + pragma Inline (Set_Label_Kind); + pragma Inline (Set_Label_Draw_Function); pragma Inline (Copy); pragma Inline (Paste); pragma Inline (Selection); + pragma Inline (Clipboard_Contains); pragma Inline (Drag_Drop_Start); pragma Inline (Get_Drag_Drop_Text_Support); @@ -427,8 +559,6 @@ private pragma Inline (Enable_System_Input); pragma Inline (Disable_System_Input); - pragma Inline (Has_Visible_Focus); - pragma Inline (Set_Visible_Focus); pragma Inline (Default_Window_Close); pragma Inline (Get_First_Window); @@ -437,7 +567,6 @@ private pragma Inline (Get_Top_Modal); pragma Inline (Read_Queue); - pragma Inline (Do_Widget_Deletion); pragma Inline (Get_Scheme); pragma Inline (Set_Scheme); @@ -451,6 +580,15 @@ private pragma Inline (Set_Default_Scrollbar_Size); + -- Needed to dealloc the argv array and deregister the clipboard notify handler + type FLTK_Static_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Static_Final_Controller); + + Cleanup : FLTK_Static_Final_Controller; + + end FLTK.Static; diff --git a/spec/fltk-widgets-groups-windows.ads b/spec/fltk-widgets-groups-windows.ads index dfa51d6..e2f9b3e 100644 --- a/spec/fltk-widgets-groups-windows.ads +++ b/spec/fltk-widgets-groups-windows.ads @@ -8,10 +8,6 @@ with FLTK.Images.RGB; -private with - - Interfaces.C.Strings; - package FLTK.Widgets.Groups.Windows is diff --git a/spec/fltk-widgets-inputs.ads b/spec/fltk-widgets-inputs.ads index 12fcb77..6de80da 100644 --- a/spec/fltk-widgets-inputs.ads +++ b/spec/fltk-widgets-inputs.ads @@ -10,8 +10,7 @@ limited with private with - Interfaces.C.Strings, - System; + Interfaces.C.Strings; package FLTK.Widgets.Inputs is diff --git a/spec/fltk-widgets-menus-menu_buttons.ads b/spec/fltk-widgets-menus-menu_buttons.ads index 033e3e5..7a93a6d 100644 --- a/spec/fltk-widgets-menus-menu_buttons.ads +++ b/spec/fltk-widgets-menus-menu_buttons.ads @@ -4,10 +4,6 @@ -- Released into the public domain -with - - FLTK.Menu_Items; - limited with FLTK.Widgets.Groups; diff --git a/spec/fltk-widgets.ads b/spec/fltk-widgets.ads index 144e1f7..67c1625 100644 --- a/spec/fltk-widgets.ads +++ b/spec/fltk-widgets.ads @@ -14,7 +14,6 @@ limited with private with - Ada.Unchecked_Conversion, System.Address_To_Access_Conversions, Interfaces.C, FLTK.Widget_Callback_Conversions; @@ -32,46 +31,6 @@ package FLTK.Widgets is (Item : in out Widget'Class); - type Callback_Flag is record - Changed : Boolean := False; - Interact : Boolean := False; - Release : Boolean := False; - Enter_Key : Boolean := False; - end record; - - function "+" (Left, Right : in Callback_Flag) return Callback_Flag; - - Call_Never : constant Callback_Flag; - When_Changed : constant Callback_Flag; - When_Interact : constant Callback_Flag; - When_Release : constant Callback_Flag; - When_Release_Always : constant Callback_Flag; - When_Enter_Key : constant Callback_Flag; - When_Enter_Key_Always : constant Callback_Flag; - - - type Damage_Mask is record - Child : Boolean := False; - Expose : Boolean := False; - Scroll : Boolean := False; - Overlay : Boolean := False; - User_1 : Boolean := False; - User_2 : Boolean := False; - Full : Boolean := False; - end record; - - function "+" (Left, Right : in Damage_Mask) return Damage_Mask; - - Damage_None : constant Damage_Mask; - Damage_Child : constant Damage_Mask; - Damage_Expose : constant Damage_Mask; - Damage_Scroll : constant Damage_Mask; - Damage_Overlay : constant Damage_Mask; - Damage_User_1 : constant Damage_Mask; - Damage_User_2 : constant Damage_Mask; - Damage_Full : constant Damage_Mask; - - package Forge is @@ -557,64 +516,6 @@ private (This : in out Widget); - for Callback_Flag use record - Changed at 0 range 0 .. 0; - Interact at 0 range 1 .. 1; - Release at 0 range 2 .. 2; - Enter_Key at 0 range 3 .. 3; - end record; - - for Callback_Flag'Size use Interfaces.C.unsigned_char'Size; - - Call_Never : constant Callback_Flag := (others => False); - When_Changed : constant Callback_Flag := (Changed => True, others => False); - When_Interact : constant Callback_Flag := (Interact => True, others => False); - When_Release : constant Callback_Flag := (Release => True, others => False); - When_Enter_Key : constant Callback_Flag := (Enter_Key => True, others => False); - - When_Release_Always : constant Callback_Flag := - (Release => True, Interact => True, others => False); - When_Enter_Key_Always : constant Callback_Flag := - (Enter_Key => True, Interact => True, others => False); - - - for Damage_Mask use record - Child at 0 range 0 .. 0; - Expose at 0 range 1 .. 1; - Scroll at 0 range 2 .. 2; - Overlay at 0 range 3 .. 3; - User_1 at 0 range 4 .. 4; - User_2 at 0 range 5 .. 5; - -- bit 6 missing - Full at 0 range 7 .. 7; - end record; - - for Damage_Mask'Size use Interfaces.C.unsigned_char'Size; - - Damage_None : constant Damage_Mask := (others => False); - Damage_Child : constant Damage_Mask := (Child => True, others => False); - Damage_Expose : constant Damage_Mask := (Expose => True, others => False); - Damage_Scroll : constant Damage_Mask := (Scroll => True, others => False); - Damage_Overlay : constant Damage_Mask := (Overlay => True, others => False); - Damage_User_1 : constant Damage_Mask := (User_1 => True, others => False); - Damage_User_2 : constant Damage_Mask := (User_2 => True, others => False); - Damage_Full : constant Damage_Mask := (Full => True, others => False); - - - function Flag_To_UChar is new - Ada.Unchecked_Conversion (Callback_Flag, Interfaces.C.unsigned_char); - - function UChar_To_Flag is new - Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Callback_Flag); - - - function Mask_To_UChar is new - Ada.Unchecked_Conversion (Damage_Mask, Interfaces.C.unsigned_char); - - function UChar_To_Mask is new - Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Damage_Mask); - - -- the user data portion should always be a reference back to the Ada binding procedure Callback_Hook (W, U : in Storage.Integer_Address); diff --git a/spec/fltk.ads b/spec/fltk.ads index 8129281..964af79 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -6,11 +6,13 @@ with - Ada.Finalization; + Ada.Finalization, + System; private with - Interfaces.C, + Ada.Unchecked_Conversion, + Interfaces.C.Strings, System.Storage_Elements; @@ -33,27 +35,70 @@ package FLTK is -- Text buffers for marshalling purposes will be this size. Buffer_Size : constant Natural := 1024; + -- For image data arrays. + type Size_Type is mod 2 ** System.Word_Size; + subtype Positive_Size is Size_Type range 1 .. Size_Type'Last; + -- Color -- - -- Values scale from A/Black to X/White + -- Values scale from A/Black to X/White. type Greyscale is new Character range 'A' .. 'X'; type Color is mod 2**32; type Color_Component is mod 256; - type Color_Component_Array is array (Positive range <>) of aliased Color_Component; + type Color_Component_Array is array (Positive_Size range <>) of aliased Color_Component; + + subtype Blend is Float range 0.0 .. 1.0; + + function RGB_Color + (Light : in Greyscale) + return Color; + + function RGB_Color + (Light : in Color_Component) + return Color; function RGB_Color (R, G, B : in Color_Component) return Color; + function Color_Cube + (R, G, B : in Color_Component) + return Color; + + function Grey_Ramp + (Light : in Greyscale) + return Color; + + function Grey_Ramp + (Light : in Color_Component) + return Color; + + function Darker + (Tone : in Color) + return Color; + + function Lighter + (Tone : in Color) + return Color; + function Contrast (Fore, Back : in Color) return Color; + function Inactive + (Tone : in Color) + return Color; + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color; + -- Examples of RGB colors without the above function -- The lowest byte has to be 00 for the color to be RGB RGB_Red_Color : constant Color := 16#ff000000#; @@ -188,7 +233,14 @@ package FLTK is Tab_Key : constant Keypress; - type Mouse_Button is (No_Button, Left_Button, Middle_Button, Right_Button); + type Mouse_Button is + (No_Button, + Left_Button, + Middle_Button, + Right_Button, + Back_Button, + Forward_Button, + Any_Button); type Key_Combo is private; @@ -282,6 +334,18 @@ package FLTK is Gleam_Round_Down_Box, Free_Box); + function Filled + (Box : in Box_Kind) + return Box_Kind; + + function Frame + (Box : in Box_Kind) + return Box_Kind; + + function Down + (Box : in Box_Kind) + return Box_Kind; + @@ -365,11 +429,45 @@ package FLTK is + -- Callback Flags -- + + type Callback_Flag is record + Changed : Boolean := False; + Interact : Boolean := False; + Release : Boolean := False; + Enter_Key : Boolean := False; + end record; + + function "+" (Left, Right : in Callback_Flag) return Callback_Flag; + function "-" (Left, Right : in Callback_Flag) return Callback_Flag; + + Call_Never : constant Callback_Flag; + When_Changed : constant Callback_Flag; + When_Interact : constant Callback_Flag; + When_Release : constant Callback_Flag; + When_Release_Always : constant Callback_Flag; + When_Enter_Key : constant Callback_Flag; + When_Enter_Key_Always : constant Callback_Flag; + + + + -- Menu Flags -- - type Menu_Flag is private; + -- It's easier to have this here rather than in Menu_Items for visibility reasons. + + type Menu_Flag is record + Inactive : Boolean := False; + Toggle : Boolean := False; + Value : Boolean := False; + Radio : Boolean := False; + Invisible : Boolean := False; + Submenu : Boolean := False; + Divider : Boolean := False; + end record; function "+" (Left, Right : in Menu_Flag) return Menu_Flag; + function "-" (Left, Right : in Menu_Flag) return Menu_Flag; Flag_Normal : constant Menu_Flag; Flag_Inactive : constant Menu_Flag; @@ -383,55 +481,65 @@ package FLTK is - -- Versioning -- - - type Version_Number is new Natural; - - function ABI_Check - (ABI_Ver : in Version_Number) - return Boolean; - - function ABI_Version - return Version_Number; + -- Damage Bits -- - function API_Version - return Version_Number; + type Damage_Mask is record + Child : Boolean := False; + Expose : Boolean := False; + Scroll : Boolean := False; + Overlay : Boolean := False; + User_1 : Boolean := False; + User_2 : Boolean := False; + Full : Boolean := False; + end record; - function Version - return Version_Number; + function "+" (Left, Right : in Damage_Mask) return Damage_Mask; + function "-" (Left, Right : in Damage_Mask) return Damage_Mask; + Damage_None : constant Damage_Mask; + Damage_Child : constant Damage_Mask; + Damage_Expose : constant Damage_Mask; + Damage_Scroll : constant Damage_Mask; + Damage_Overlay : constant Damage_Mask; + Damage_User_1 : constant Damage_Mask; + Damage_User_2 : constant Damage_Mask; + Damage_Full : constant Damage_Mask; - -- Threads -- - procedure Awake; + -- Clipboard Attributes -- - procedure Lock; + Clipboard_Image : constant String; + Clipboard_Plain_Text : constant String; - procedure Unlock; + -- Versioning -- - -- Drawing -- + type Version_Number is new Natural; - -- Need to check/revise these damage bits... - function Is_Damaged + function ABI_Check + (ABI_Ver : in Version_Number) return Boolean; - procedure Set_Damaged - (To : in Boolean); + function ABI_Version + return Version_Number; - procedure Flush; + function API_Version + return Version_Number; - procedure Redraw; + function Version + return Version_Number; -- Event Loop -- + procedure Check; + function Check return Boolean; @@ -443,7 +551,7 @@ package FLTK is function Wait (Seconds : in Long_Float) - return Integer; + return Long_Float; function Run return Integer; @@ -480,18 +588,16 @@ private -- Note: This has to be Limited because otherwise the various init subprograms -- wouldn't work, the widget callbacks wouldn't work, deallocation would be -- a mess, really just all sorts of problems. - type Wrapper is new Ada.Finalization.Limited_Controlled with - record - Void_Ptr : Storage.Integer_Address := Null_Pointer; - Needs_Dealloc : Boolean := True; - end record; + type Wrapper is new Ada.Finalization.Limited_Controlled with record + Void_Ptr : Storage.Integer_Address := Null_Pointer; + Needs_Dealloc : Boolean := True; + end record; for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT; pragma Convention (C, Color_Component_Array); - pragma Pack (Color_Component_Array); @@ -569,34 +675,34 @@ private function To_C (Key : in Key_Combo) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Key_Combo; function To_C (Key : in Keypress) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress; function To_C (Modi : in Modifier) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier; function To_C (Button : in Mouse_Button) - return Interfaces.C.int; + return Interfaces.C.unsigned; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) return Mouse_Button; -- these values designed to align with FLTK enumeration types @@ -635,48 +741,128 @@ private - type Menu_Flag is new Interfaces.Unsigned_8; + for Callback_Flag use record + Changed at 0 range 0 .. 0; + Interact at 0 range 1 .. 1; + Release at 0 range 2 .. 2; + Enter_Key at 0 range 3 .. 3; + end record; + + for Callback_Flag'Size use Interfaces.C.unsigned_char'Size; + + Call_Never : constant Callback_Flag := (others => False); + When_Changed : constant Callback_Flag := (Changed => True, others => False); + When_Interact : constant Callback_Flag := (Interact => True, others => False); + When_Release : constant Callback_Flag := (Release => True, others => False); + When_Enter_Key : constant Callback_Flag := (Enter_Key => True, others => False); - Flag_Normal : constant Menu_Flag := 2#00000000#; - Flag_Inactive : constant Menu_Flag := 2#00000001#; - Flag_Toggle : constant Menu_Flag := 2#00000010#; - Flag_Value : constant Menu_Flag := 2#00000100#; - Flag_Radio : constant Menu_Flag := 2#00001000#; - Flag_Invisible : constant Menu_Flag := 2#00010000#; - -- Flag_Submenu_Pointer unlikely to be used - Flag_Submenu : constant Menu_Flag := 2#01000000#; - Flag_Divider : constant Menu_Flag := 2#10000000#; + When_Release_Always : constant Callback_Flag := + (Release => True, Interact => True, others => False); + When_Enter_Key_Always : constant Callback_Flag := + (Enter_Key => True, Interact => True, others => False); + function Flag_To_UChar is new + Ada.Unchecked_Conversion (Callback_Flag, Interfaces.C.unsigned_char); + function UChar_To_Flag is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Callback_Flag); - pragma Import (C, Awake, "fl_awake"); - pragma Import (C, Lock, "fl_lock"); - pragma Import (C, Unlock, "fl_unlock"); - pragma Import (C, Flush, "fl_flush"); - pragma Import (C, Redraw, "fl_redraw"); + + for Menu_Flag use record + Inactive at 0 range 0 .. 0; + Toggle at 0 range 1 .. 1; + Value at 0 range 2 .. 2; + Radio at 0 range 3 .. 3; + Invisible at 0 range 4 .. 4; + -- Submenu_Pointer unused + Submenu at 0 range 6 .. 6; + Divider at 0 range 7 .. 7; + end record; + + for Menu_Flag'Size use Interfaces.C.int'Size; + + Flag_Normal : constant Menu_Flag := (others => False); + Flag_Inactive : constant Menu_Flag := (Inactive => True, others => False); + Flag_Toggle : constant Menu_Flag := (Toggle => True, others => False); + Flag_Value : constant Menu_Flag := (Value => True, others => False); + Flag_Radio : constant Menu_Flag := (Radio => True, others => False); + Flag_Invisible : constant Menu_Flag := (Invisible => True, others => False); + -- Flag_Submenu_Pointer unused + Flag_Submenu : constant Menu_Flag := (Submenu => True, others => False); + Flag_Divider : constant Menu_Flag := (Divider => True, others => False); + + function MFlag_To_Cint is new + Ada.Unchecked_Conversion (Menu_Flag, Interfaces.C.int); + + function Cint_To_MFlag is new + Ada.Unchecked_Conversion (Interfaces.C.int, Menu_Flag); + + + + + for Damage_Mask use record + Child at 0 range 0 .. 0; + Expose at 0 range 1 .. 1; + Scroll at 0 range 2 .. 2; + Overlay at 0 range 3 .. 3; + User_1 at 0 range 4 .. 4; + User_2 at 0 range 5 .. 5; + -- bit 6 missing + Full at 0 range 7 .. 7; + end record; + + for Damage_Mask'Size use Interfaces.C.unsigned_char'Size; + + Damage_None : constant Damage_Mask := (others => False); + Damage_Child : constant Damage_Mask := (Child => True, others => False); + Damage_Expose : constant Damage_Mask := (Expose => True, others => False); + Damage_Scroll : constant Damage_Mask := (Scroll => True, others => False); + Damage_Overlay : constant Damage_Mask := (Overlay => True, others => False); + Damage_User_1 : constant Damage_Mask := (User_1 => True, others => False); + Damage_User_2 : constant Damage_Mask := (User_2 => True, others => False); + Damage_Full : constant Damage_Mask := (Full => True, others => False); + + function Mask_To_UChar is new + Ada.Unchecked_Conversion (Damage_Mask, Interfaces.C.unsigned_char); + + function UChar_To_Mask is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Damage_Mask); + + + + + clip_image_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_image_char_ptr, "fl_clip_image_char_ptr"); + + clip_plain_text_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_plain_text_char_ptr, "fl_clip_plain_text_char_ptr"); + + Clipboard_Image : constant String := Interfaces.C.Strings.Value (clip_image_char_ptr); + Clipboard_Plain_Text : constant String := Interfaces.C.Strings.Value (clip_plain_text_char_ptr); pragma Inline (RGB_Color); + pragma Inline (Color_Cube); + pragma Inline (Grey_Ramp); + pragma Inline (Darker); + pragma Inline (Lighter); pragma Inline (Contrast); + pragma Inline (Inactive); + pragma Inline (Color_Average); + + pragma Inline (Filled); + pragma Inline (Frame); + pragma Inline (Down); pragma Inline (ABI_Check); pragma Inline (ABI_Version); pragma Inline (API_Version); pragma Inline (Version); - pragma Inline (Awake); - pragma Inline (Lock); - pragma Inline (Unlock); - - pragma Inline (Is_Damaged); - pragma Inline (Set_Damaged); - pragma Inline (Flush); - pragma Inline (Redraw); - pragma Inline (Check); pragma Inline (Ready); pragma Inline (Wait); |