From ba40e0e277a2a959209e082fd62a3c2e796a9566 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 24 Dec 2024 12:33:28 +1300 Subject: Completed Fl_Surface_Device binding --- doc/fl_device.html | 33 ++++++++++ doc/fl_surface_device.html | 57 ++++++++++++++--- progress.txt | 12 ++-- src/c_fl_surface.cpp | 13 +++- src/c_fl_surface.h | 9 +-- src/fltk-devices-surface-copy.adb | 2 +- src/fltk-devices-surface-image.adb | 2 +- src/fltk-devices-surface-paged-printers.adb | 2 +- src/fltk-devices-surface.adb | 96 +++++++++++++++++++++++++++-- src/fltk-devices-surface.ads | 40 +++++++++--- src/fltk-devices.ads | 3 + 11 files changed, 230 insertions(+), 39 deletions(-) diff --git a/doc/fl_device.html b/doc/fl_device.html index 086a45c..c87b543 100644 --- a/doc/fl_device.html +++ b/doc/fl_device.html @@ -36,6 +36,39 @@ Device + +   + Device_Reference + + + + + + + + + + + + + + +
Static Attributes
+static const char * class_id = "Fl_Device";
+
Use runtime tag checks instead
+ + + + + + + + + + +
Functions and Procedures
+virtual const char * class_name();
+
Deprecated, use runtime tag checks instead
diff --git a/doc/fl_surface_device.html b/doc/fl_surface_device.html index f4fa6e4..b6ba5f5 100644 --- a/doc/fl_surface_device.html +++ b/doc/fl_surface_device.html @@ -46,7 +46,21 @@ - + + + + + + + +
Functions and Procedures
Static Attributes
+static const char * class_id = "Fl_Surface_Device";
+
Use runtime tag checks instead
+ + + + + +
Constructors
@@ -54,11 +68,18 @@ Fl_Surface_Device(Fl_Graphics_Driver *graphics_driver);
 
 function Create
-       (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver)
+       (Graphics : in FLTK.Devices.Graphics.Graphics_Driver)
     return Surface_Device;
+ + + + + + + - + - @@ -90,13 +123,23 @@ procedure Set_Current +
Functions and Procedures
 const char * class_name();
@@ -68,16 +89,28 @@ const char * class_name();
 
   
-void driver(Fl_Graphics_Driver *graphics_driver);
+Fl_Graphics_Driver * driver();
+
+function Has_Driver
+       (This : in Surface_Device)
+    return Boolean;
+
+function Get_Driver
+       (This : in out Surface_Device)
+    return FLTK.Devices.Graphics.Graphics_Driver_Reference;
TBA 
-Fl_Graphics_Driver * driver();
+void driver(Fl_Graphics_Driver *graphics_driver);
+
+procedure Set_Driver
+       (This   : in out Surface_Device;
+        Driver : in     FLTK.Devices.Graphics.Graphics_Driver'Class);
TBA
+ + + + + + diff --git a/progress.txt b/progress.txt index 3ad93bb..8a0cb74 100644 --- a/progress.txt +++ b/progress.txt @@ -15,10 +15,11 @@ Done: FLTK FLTK.Asks FLTK.Devices -FLTK.Devices.Surfaces.Copy -FLTK.Devices.Surfaces.Image -FLTK.Devices.Surfaces.Paged -FLTK.Devices.Surfaces.Paged.Printers +FLTK.Devices.Surface +FLTK.Devices.Surface.Copy +FLTK.Devices.Surface.Image +FLTK.Devices.Surface.Paged +FLTK.Devices.Surface.Paged.Printers FLTK.Draw FLTK.Environment FLTK.Errors @@ -125,8 +126,7 @@ FLTK.Widgets.Valuators.Value_Outputs Partially Done: -FLTK.Devices.Graphics (incomplete API, otherwise polished) -FLTK.Devices.Surfaces (incomplete API, otherwise polished) +Fl_Graphics_Driver / FLTK.Devices.Graphics diff --git a/src/c_fl_surface.cpp b/src/c_fl_surface.cpp index 08fbc2d..9fb21ca 100644 --- a/src/c_fl_surface.cpp +++ b/src/c_fl_surface.cpp @@ -11,9 +11,9 @@ class My_Surface_Device : public Fl_Surface_Device { - public: - using Fl_Surface_Device::Fl_Surface_Device; - friend SURFACE new_fl_surface(void * g); +public: + using Fl_Surface_Device::Fl_Surface_Device; + friend SURFACE new_fl_surface(void * g); }; @@ -41,3 +41,10 @@ SURFACE fl_surface_get_surface(void) { } + + +void fl_surface_set_driver(SURFACE s, void * g) { + reinterpret_cast(s)->driver(reinterpret_cast(g)); +} + + diff --git a/src/c_fl_surface.h b/src/c_fl_surface.h index 9f8bdad..bdbfe2d 100644 --- a/src/c_fl_surface.h +++ b/src/c_fl_surface.h @@ -8,22 +8,19 @@ #define FL_SURFACE_GUARD - - typedef void* SURFACE; - - extern "C" SURFACE new_fl_surface(void * g); extern "C" void free_fl_surface(SURFACE s); - - extern "C" void fl_surface_set_current(SURFACE s); extern "C" SURFACE fl_surface_get_surface(void); +extern "C" void fl_surface_set_driver(SURFACE s, void * g); + + #endif diff --git a/src/fltk-devices-surface-copy.adb b/src/fltk-devices-surface-copy.adb index fe96f91..7bb1c66 100644 --- a/src/fltk-devices-surface-copy.adb +++ b/src/fltk-devices-surface-copy.adb @@ -147,7 +147,7 @@ package body FLTK.Devices.Surface.Copy is (This : in out Copy_Surface) is begin fl_copy_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; + This.Set_Current_Bookkeep; end Set_Current; diff --git a/src/fltk-devices-surface-image.adb b/src/fltk-devices-surface-image.adb index d9a5e1b..e9e7de4 100644 --- a/src/fltk-devices-surface-image.adb +++ b/src/fltk-devices-surface-image.adb @@ -162,7 +162,7 @@ package body FLTK.Devices.Surface.Image is (This : in out Image_Surface) is begin fl_image_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; + This.Set_Current_Bookkeep; end Set_Current; diff --git a/src/fltk-devices-surface-paged-printers.adb b/src/fltk-devices-surface-paged-printers.adb index f5c964a..d454f78 100644 --- a/src/fltk-devices-surface-paged-printers.adb +++ b/src/fltk-devices-surface-paged-printers.adb @@ -349,7 +349,7 @@ package body FLTK.Devices.Surface.Paged.Printers is (This : in out Printer) is begin fl_printer_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; + This.Set_Current_Bookkeep; end Set_Current; diff --git a/src/fltk-devices-surface.adb b/src/fltk-devices-surface.adb index fc8e077..9a93768 100644 --- a/src/fltk-devices-surface.adb +++ b/src/fltk-devices-surface.adb @@ -7,6 +7,10 @@ package body FLTK.Devices.Surface is + ------------------------ + -- Functions From C -- + ------------------------ + function new_fl_surface (G : in Storage.Integer_Address) return Storage.Integer_Address; @@ -34,6 +38,18 @@ package body FLTK.Devices.Surface is + procedure fl_surface_set_driver + (S, G : in Storage.Integer_Address); + pragma Import (C, fl_surface_set_driver, "fl_surface_set_driver"); + pragma Inline (fl_surface_set_driver); + + + + + ------------------- + -- Destructors -- + ------------------- + procedure Finalize (This : in out Surface_Device) is begin @@ -46,28 +62,60 @@ package body FLTK.Devices.Surface is + -------------------- + -- Constructors -- + -------------------- + + procedure Initialize + (This : in out Surface_Device) is + begin + Wrapper (This.My_Driver).Needs_Dealloc := False; + end Initialize; + + package body Forge is function Create - (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + (Graphics : in FLTK.Devices.Graphics.Graphics_Driver) return Surface_Device is begin return This : Surface_Device do This.Void_Ptr := new_fl_surface (Wrapper (Graphics).Void_Ptr); + Wrapper (This.My_Driver).Void_Ptr := Wrapper (Graphics).Void_Ptr; end return; end Create; - pragma Inline (Create); - end Forge; + ------------------------- + -- Static Attributes -- + ------------------------- + + Original_Surface : aliased Surface_Device; + Current_Surface : aliased Surface_Device; + + + procedure Set_Current_Bookkeep + (Surface : in Surface_Device'Class) is + begin + Current_Surface.Void_Ptr := Surface.Void_Ptr; + Wrapper (Current_Surface.My_Driver).Void_Ptr := Wrapper (Surface.My_Driver).Void_Ptr; + end Set_Current_Bookkeep; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + function Get_Current - return access Surface_Device'Class is + return Surface_Device_Reference is begin - return Current_Ptr; + return Ref : Surface_Device_Reference (Data => Current_Surface'Access); end Get_Current; @@ -75,10 +123,43 @@ package body FLTK.Devices.Surface is (This : in out Surface_Device) is begin fl_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; + This.Set_Current_Bookkeep; end Set_Current; + function Get_Original + return Surface_Device_Reference is + begin + return Ref : Surface_Device_Reference (Data => Original_Surface'Access); + end Get_Original; + + + + + function Has_Driver + (This : in Surface_Device) + return Boolean is + begin + return Wrapper (This.My_Driver).Void_Ptr /= Null_Pointer; + end Has_Driver; + + + function Get_Driver + (This : in out Surface_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference is + begin + return Ref : FLTK.Devices.Graphics.Graphics_Driver_Reference + (Data => This.My_Driver'Unchecked_Access); + end Get_Driver; + + + procedure Set_Driver + (This : in out Surface_Device; + Driver : in FLTK.Devices.Graphics.Graphics_Driver'Class) is + begin + fl_surface_set_driver (This.Void_Ptr, Wrapper (Driver).Void_Ptr); + Wrapper (This.My_Driver).Void_Ptr := Wrapper (Driver).Void_Ptr; + end Set_Driver; begin @@ -87,6 +168,9 @@ begin Original_Surface.Void_Ptr := fl_surface_get_surface; Original_Surface.Needs_Dealloc := False; + Current_Surface.Void_Ptr := Original_Surface.Void_Ptr; + Current_Surface.Needs_Dealloc := False; + end FLTK.Devices.Surface; diff --git a/src/fltk-devices-surface.ads b/src/fltk-devices-surface.ads index 8ca367c..cbad055 100644 --- a/src/fltk-devices-surface.ads +++ b/src/fltk-devices-surface.ads @@ -15,8 +15,6 @@ package FLTK.Devices.Surface is pragma Elaborate_Body (FLTK.Devices.Surface); - - type Surface_Device is new Device with private; type Surface_Device_Reference (Data : not null access Surface_Device'Class) is @@ -28,7 +26,7 @@ package FLTK.Devices.Surface is package Forge is function Create - (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + (Graphics : in FLTK.Devices.Graphics.Graphics_Driver) return Surface_Device; end Forge; @@ -37,27 +35,53 @@ package FLTK.Devices.Surface is function Get_Current - return access Surface_Device'Class; + return Surface_Device_Reference; procedure Set_Current (This : in out Surface_Device); + function Get_Original + return Surface_Device_Reference; + + + + + function Has_Driver + (This : in Surface_Device) + return Boolean; + + function Get_Driver + (This : in out Surface_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference; + + procedure Set_Driver + (This : in out Surface_Device; + Driver : in FLTK.Devices.Graphics.Graphics_Driver'Class); + private - type Surface_Device is new Device with null record; + type Surface_Device is new Device with record + My_Driver : aliased FLTK.Devices.Graphics.Graphics_Driver; + end record; + + overriding procedure Initialize + (This : in out Surface_Device); overriding procedure Finalize (This : in out Surface_Device); - Original_Surface : aliased Surface_Device; - Current_Ptr : access Surface_Device'Class := Original_Surface'Access; + procedure Set_Current_Bookkeep + (Surface : in Surface_Device'Class); pragma Inline (Get_Current); - pragma Inline (Set_Current); + pragma Inline (Get_Original); + + pragma Inline (Has_Driver); + pragma Inline (Get_Driver); end FLTK.Devices.Surface; diff --git a/src/fltk-devices.ads b/src/fltk-devices.ads index 517bd73..d9ce5b1 100644 --- a/src/fltk-devices.ads +++ b/src/fltk-devices.ads @@ -9,6 +9,9 @@ package FLTK.Devices is type Device is new Wrapper with private; + type Device_Reference (Data : not null access Device'Class) is + limited null record with Implicit_Dereference => Data; + private -- cgit
Static Functions and Procedures
 static Fl_Surface_Device * surface();
 
 function Get_Current
-    return access Surface_Device'Class;
+    return Surface_Device_Reference;
+
+function Get_Original
+    return Surface_Device_Reference;