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 | 44 | ||||
| -rw-r--r-- | spec/fltk-images-bitmaps.ads | 23 | ||||
| -rw-r--r-- | spec/fltk-images-rgb.ads | 22 | ||||
| -rw-r--r-- | spec/fltk-static.ads | 220 | ||||
| -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.ads | 12 |
11 files changed, 264 insertions, 95 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-events.ads b/spec/fltk-events.ads index 6a556ff..5dbc573 100644 --- a/spec/fltk-events.ads +++ b/spec/fltk-events.ads @@ -6,11 +6,12 @@ with - FLTK.Widgets.Groups.Windows; + FLTK.Widgets.Groups.Windows, + System; private with - Ada.Containers.Vectors, + Ada.Finalization, System.Address_To_Access_Conversions; @@ -27,15 +28,33 @@ package FLTK.Events is return Event_Outcome; + type System_Event is new System.Address; + + type System_Handler is access function + (Event : in System_Event) + return Event_Outcome; + + -- 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); + + procedure Remove_System_Handler + (Func : in not null System_Handler); + + + + + -- Dispatch -- function Get_Dispatch return Event_Dispatch; @@ -255,11 +274,6 @@ 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; @@ -275,6 +289,9 @@ private pragma Inline (Add_Handler); pragma Inline (Remove_Handler); + pragma Inline (Add_System_Handler); + pragma Inline (Remove_System_Handler); + pragma Inline (Get_Dispatch); pragma Inline (Set_Dispatch); pragma Inline (Handle_Dispatch); @@ -333,6 +350,15 @@ private pragma Inline (Key_Shift); + -- 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-static.ads b/spec/fltk-static.ads index 6b54878..4f71244 100644 --- a/spec/fltk-static.ads +++ b/spec/fltk-static.ads @@ -6,16 +6,26 @@ 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 + -- 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 Awake_Handler is access procedure; type Idle_Handler is access procedure; @@ -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,20 +80,51 @@ 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); -- 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); function Get_Awake_Handler return Awake_Handler; + procedure Awake + (Func : in Awake_Handler); + procedure Awake; procedure Lock; @@ -73,14 +137,14 @@ package FLTK.Static is -- 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); @@ -88,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); @@ -108,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); @@ -119,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); @@ -140,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 @@ -193,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) @@ -229,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); + + + - -- 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); + -- Label_Kind Attributes -- + + 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); @@ -256,6 +351,10 @@ package FLTK.Static is (Owner : in FLTK.Widgets.Widget'Class; Text : in String); + function Clipboard_Contains + (Kind : in String) + return Boolean; + @@ -352,25 +451,49 @@ 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, Awake, "fl_static_awake"); 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, Reload_Scheme, "fl_static_reload_scheme"); + pragma Inline (Parse_Arg); + pragma Inline (Add_Awake_Handler); pragma Inline (Get_Awake_Handler); pragma Inline (Awake); @@ -399,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); @@ -417,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); @@ -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.ads b/spec/fltk.ads index 2a38434..964af79 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -6,7 +6,8 @@ with - Ada.Finalization; + Ada.Finalization, + System; private with @@ -34,18 +35,22 @@ 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; @@ -593,7 +598,6 @@ private for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT; pragma Convention (C, Color_Component_Array); - pragma Pack (Color_Component_Array); |