summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c_fl_surface.cpp13
-rw-r--r--src/c_fl_surface.h9
-rw-r--r--src/fltk-devices-surface-copy.adb2
-rw-r--r--src/fltk-devices-surface-image.adb2
-rw-r--r--src/fltk-devices-surface-paged-printers.adb2
-rw-r--r--src/fltk-devices-surface.adb96
-rw-r--r--src/fltk-devices-surface.ads40
-rw-r--r--src/fltk-devices.ads3
8 files changed, 141 insertions, 26 deletions
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<Fl_Surface_Device*>(s)->driver(reinterpret_cast<Fl_Graphics_Driver*>(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
generated by cgit (git 2.30.0) at 2025-01-15 18:36:33 +0000