From 5aa2cbc50e016fd833b35603c73b0a88692607f3 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sat, 24 Mar 2018 14:36:52 +1100 Subject: Added FLTK.Devices.Surfaces --- src/c_fl_surface.cpp | 38 +++++++++++++++++ src/c_fl_surface.h | 25 +++++++++++ src/fltk-devices-surfaces.adb | 96 +++++++++++++++++++++++++++++++++++++++++++ src/fltk-devices-surfaces.ads | 48 ++++++++++++++++++++++ 4 files changed, 207 insertions(+) create mode 100644 src/c_fl_surface.cpp create mode 100644 src/c_fl_surface.h create mode 100644 src/fltk-devices-surfaces.adb create mode 100644 src/fltk-devices-surfaces.ads (limited to 'src') diff --git a/src/c_fl_surface.cpp b/src/c_fl_surface.cpp new file mode 100644 index 0000000..89d661f --- /dev/null +++ b/src/c_fl_surface.cpp @@ -0,0 +1,38 @@ + + +#include +#include "c_fl_surface.h" + + + + +class My_Surface_Device : public Fl_Surface_Device { + public: + using Fl_Surface_Device::Fl_Surface_Device; + friend SURFACE new_fl_surface(void * g); +}; + + + + +SURFACE new_fl_surface(void * g) { + My_Surface_Device *s = new My_Surface_Device(reinterpret_cast(g)); + return s; +} + +void free_fl_surface(SURFACE s) { + delete reinterpret_cast(s); +} + + + + +void fl_surface_set_current(SURFACE s) { + reinterpret_cast(s)->set_current(); +} + +SURFACE fl_surface_get_surface(void) { + return Fl_Surface_Device::surface(); +} + + diff --git a/src/c_fl_surface.h b/src/c_fl_surface.h new file mode 100644 index 0000000..dd8d8e9 --- /dev/null +++ b/src/c_fl_surface.h @@ -0,0 +1,25 @@ + + +#ifndef FL_SURFACE_GUARD +#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); + + +#endif + diff --git a/src/fltk-devices-surfaces.adb b/src/fltk-devices-surfaces.adb new file mode 100644 index 0000000..a0c5042 --- /dev/null +++ b/src/fltk-devices-surfaces.adb @@ -0,0 +1,96 @@ + + +with + + System; + +use type + + System.Address; + + +package body FLTK.Devices.Surfaces is + + + function new_fl_surface + (G : in System.Address) + return System.Address; + pragma Import (C, new_fl_surface, "new_fl_surface"); + + procedure free_fl_surface + (S : in System.Address); + pragma Import (C, free_fl_surface, "free_fl_surface"); + + + + + procedure fl_surface_set_current + (S : in System.Address); + pragma Import (C, fl_surface_set_current, "fl_surface_set_current"); + + function fl_surface_get_surface + return System.Address; + pragma Import (C, fl_surface_get_surface, "fl_surface_get_surface"); + + + + + procedure Finalize + (This : in out Surface_Device) is + begin + if This.Void_Ptr /= System.Null_Address and then + This in Surface_Device'Class + then + if This.Needs_Dealloc then + free_fl_surface (This.Void_Ptr); + end if; + This.Void_Ptr := System.Null_Address; + end if; + Finalize (Device (This)); + end Finalize; + + + + + package body Forge is + + function Create + (Graphics : in out 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); + end return; + end Create; + + end Forge; + + + + + function Get_Current + return access Surface_Device is + begin + return Current_Ptr; + end Get_Current; + + + procedure Set_Current + (This : in out Surface_Device) is + begin + fl_surface_set_current (This.Void_Ptr); + Current_Ptr := This'Unchecked_Access; + end Set_Current; + + + + +begin + + + Original_Surface.Void_Ptr := fl_surface_get_surface; + Original_Surface.Needs_Dealloc := False; + + +end FLTK.Devices.Surfaces; + diff --git a/src/fltk-devices-surfaces.ads b/src/fltk-devices-surfaces.ads new file mode 100644 index 0000000..da3d0a6 --- /dev/null +++ b/src/fltk-devices-surfaces.ads @@ -0,0 +1,48 @@ + + +with + + FLTK.Devices.Graphics; + + +package FLTK.Devices.Surfaces is + + + type Surface_Device is new Device with private; + + + + + package Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Surface_Device; + + end Forge; + + + + + function Get_Current + return access Surface_Device; + + procedure Set_Current + (This : in out Surface_Device); + + +private + + + type Surface_Device is new Device with null record; + + overriding procedure Finalize + (This : in out Surface_Device); + + + Original_Surface : aliased Surface_Device; + Current_Ptr : access Surface_Device := Original_Surface'Access; + + +end FLTK.Devices.Surfaces; + -- cgit