diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c_fl_display_device.cpp | 29 | ||||
| -rw-r--r-- | src/c_fl_display_device.h | 23 | ||||
| -rw-r--r-- | src/c_fl_surface.h | 26 | ||||
| -rw-r--r-- | src/c_fl_surface_device.cpp (renamed from src/c_fl_surface.cpp) | 18 | ||||
| -rw-r--r-- | src/c_fl_surface_device.h | 27 | ||||
| -rw-r--r-- | src/fltk-devices-surface-display.adb | 118 | ||||
| -rw-r--r-- | src/fltk-devices-surface-display.ads | 53 | ||||
| -rw-r--r-- | src/fltk-devices-surface.adb | 56 | ||||
| -rw-r--r-- | src/fltk-devices-surface.ads | 3 |
9 files changed, 296 insertions, 57 deletions
diff --git a/src/c_fl_display_device.cpp b/src/c_fl_display_device.cpp new file mode 100644 index 0000000..9c88151 --- /dev/null +++ b/src/c_fl_display_device.cpp @@ -0,0 +1,29 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/Fl_Device.H> +#include "c_fl_display_device.h" + + + + +DISPLAYDEVICE new_fl_display_device(void * g) { + Fl_Display_Device *d = new Fl_Display_Device(reinterpret_cast<Fl_Graphics_Driver*>(g)); + return d; +} + +void free_fl_display_device(DISPLAYDEVICE d) { + delete reinterpret_cast<Fl_Display_Device*>(d); +} + + + + +DISPLAYDEVICE fl_display_device_display_device() { + return Fl_Display_Device::display_device(); +} + + diff --git a/src/c_fl_display_device.h b/src/c_fl_display_device.h new file mode 100644 index 0000000..1cf530c --- /dev/null +++ b/src/c_fl_display_device.h @@ -0,0 +1,23 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_DISPLAY_DEVICE_GUARD +#define FL_DISPLAY_DEVICE_GUARD + + +typedef void* DISPLAYDEVICE; + + +extern "C" DISPLAYDEVICE new_fl_display_device(void * g); +extern "C" void free_fl_display_device(DISPLAYDEVICE d); + + +extern "C" DISPLAYDEVICE fl_display_device_display_device(); + + +#endif + + diff --git a/src/c_fl_surface.h b/src/c_fl_surface.h deleted file mode 100644 index bdbfe2d..0000000 --- a/src/c_fl_surface.h +++ /dev/null @@ -1,26 +0,0 @@ - - -// Programmed by Jedidiah Barber -// Released into the public domain - - -#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); - - -extern "C" void fl_surface_set_driver(SURFACE s, void * g); - - -#endif - diff --git a/src/c_fl_surface.cpp b/src/c_fl_surface_device.cpp index 9fb21ca..34b2bac 100644 --- a/src/c_fl_surface.cpp +++ b/src/c_fl_surface_device.cpp @@ -5,7 +5,7 @@ #include <FL/Fl_Device.H> -#include "c_fl_surface.h" +#include "c_fl_surface_device.h" @@ -13,37 +13,41 @@ class My_Surface_Device : public Fl_Surface_Device { public: using Fl_Surface_Device::Fl_Surface_Device; - friend SURFACE new_fl_surface(void * g); + friend SURFACEDEVICE new_fl_surface_device(void * g); }; -SURFACE new_fl_surface(void * g) { +SURFACEDEVICE new_fl_surface_device(void * g) { My_Surface_Device *s = new My_Surface_Device(reinterpret_cast<Fl_Graphics_Driver*>(g)); return s; } -void free_fl_surface(SURFACE s) { +void free_fl_surface_device(SURFACEDEVICE s) { delete reinterpret_cast<My_Surface_Device*>(s); } -void fl_surface_set_current(SURFACE s) { +void fl_surface_device_set_current(SURFACEDEVICE s) { // virtual so disable dispatch reinterpret_cast<Fl_Surface_Device*>(s)->Fl_Surface_Device::set_current(); } -SURFACE fl_surface_get_surface(void) { +SURFACEDEVICE fl_surface_device_get_surface(void) { return Fl_Surface_Device::surface(); } -void fl_surface_set_driver(SURFACE s, void * g) { +void * fl_surface_device_get_driver(SURFACEDEVICE s) { + return reinterpret_cast<Fl_Surface_Device*>(s)->driver(); +} + +void fl_surface_device_set_driver(SURFACEDEVICE s, void * g) { reinterpret_cast<Fl_Surface_Device*>(s)->driver(reinterpret_cast<Fl_Graphics_Driver*>(g)); } diff --git a/src/c_fl_surface_device.h b/src/c_fl_surface_device.h new file mode 100644 index 0000000..fa5946a --- /dev/null +++ b/src/c_fl_surface_device.h @@ -0,0 +1,27 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_SURFACE_DEVICE_GUARD +#define FL_SURFACE_DEVICE_GUARD + + +typedef void* SURFACEDEVICE; + + +extern "C" SURFACEDEVICE new_fl_surface_device(void * g); +extern "C" void free_fl_surface_device(SURFACEDEVICE s); + + +extern "C" void fl_surface_device_set_current(SURFACEDEVICE s); +extern "C" SURFACEDEVICE fl_surface_device_get_surface(void); + + +extern "C" void * fl_surface_device_get_driver(SURFACEDEVICE s); +extern "C" void fl_surface_device_set_driver(SURFACEDEVICE s, void * g); + + +#endif + diff --git a/src/fltk-devices-surface-display.adb b/src/fltk-devices-surface-display.adb new file mode 100644 index 0000000..ad35012 --- /dev/null +++ b/src/fltk-devices-surface-display.adb @@ -0,0 +1,118 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package body FLTK.Devices.Surface.Display is + + + ------------------------ + -- Functions From C -- + ------------------------ + + function new_fl_display_device + (G : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_display_device, "new_fl_display_device"); + pragma Inline (new_fl_display_device); + + procedure free_fl_display_device + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_display_device, "free_fl_display_device"); + pragma Inline (free_fl_display_device); + + + + + function fl_display_device_display_device + return Storage.Integer_Address; + pragma Import (C, fl_display_device_display_device, "fl_display_device_display_device"); + pragma Inline (fl_display_device_display_device); + + + + + function fl_surface_device_get_driver + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_surface_device_get_driver, "fl_surface_device_get_driver"); + pragma Inline (fl_surface_device_get_driver); + + + + + ------------------- + -- Destructors -- + ------------------- + + procedure Finalize + (This : in out Display_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_display_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + -------------------- + -- Constructors -- + -------------------- + + package body Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Display_Device is + begin + return This : Display_Device do + This.Void_Ptr := new_fl_display_device (Wrapper (Graphics).Void_Ptr); + This.My_Driver := Graphics'Unchecked_Access; + end return; + end Create; + + end Forge; + + + + + ------------------------- + -- Static Attributes -- + ------------------------- + + Platform_Display : aliased Display_Device; + Platform_Graphics : aliased FLTK.Devices.Graphics.Graphics_Driver; + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + function Get_Platform_Display + return Display_Device_Reference is + begin + return Ref : Display_Device_Reference (Data => Platform_Display'Access); + end Get_Platform_Display; + + +begin + + + Platform_Display.Void_Ptr := fl_display_device_display_device; + Platform_Display.Needs_Dealloc := False; + + Wrapper (Platform_Graphics).Void_Ptr := + fl_surface_device_get_driver (Platform_Display.Void_Ptr); + Wrapper (Platform_Graphics).Needs_Dealloc := False; + + Platform_Display.My_Driver := Platform_Graphics'Access; + + +end FLTK.Devices.Surface.Display; + + diff --git a/src/fltk-devices-surface-display.ads b/src/fltk-devices-surface-display.ads new file mode 100644 index 0000000..b581be7 --- /dev/null +++ b/src/fltk-devices-surface-display.ads @@ -0,0 +1,53 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Devices.Graphics; + + +package FLTK.Devices.Surface.Display is + + + type Display_Device is new Surface_Device with private; + + type Display_Device_Reference (Data : not null access Display_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + -- Docs say you shouldn't ever need to use this, but it's here anyway. + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Display_Device; + + end Forge; + + + + + function Get_Platform_Display + return Display_Device_Reference; + + +private + + + type Display_Device is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Display_Device); + + + pragma Inline (Get_Platform_Display); + + +end FLTK.Devices.Surface.Display; + + diff --git a/src/fltk-devices-surface.adb b/src/fltk-devices-surface.adb index 8ae558d..a6ef6cc 100644 --- a/src/fltk-devices-surface.adb +++ b/src/fltk-devices-surface.adb @@ -11,37 +11,43 @@ package body FLTK.Devices.Surface is -- Functions From C -- ------------------------ - function new_fl_surface + function new_fl_surface_device (G : in Storage.Integer_Address) return Storage.Integer_Address; - pragma Import (C, new_fl_surface, "new_fl_surface"); - pragma Inline (new_fl_surface); + pragma Import (C, new_fl_surface_device, "new_fl_surface_device"); + pragma Inline (new_fl_surface_device); - procedure free_fl_surface + procedure free_fl_surface_device (S : in Storage.Integer_Address); - pragma Import (C, free_fl_surface, "free_fl_surface"); - pragma Inline (free_fl_surface); + pragma Import (C, free_fl_surface_device, "free_fl_surface_device"); + pragma Inline (free_fl_surface_device); - procedure fl_surface_set_current + procedure fl_surface_device_set_current (S : in Storage.Integer_Address); - pragma Import (C, fl_surface_set_current, "fl_surface_set_current"); - pragma Inline (fl_surface_set_current); + pragma Import (C, fl_surface_device_set_current, "fl_surface_device_set_current"); + pragma Inline (fl_surface_device_set_current); - function fl_surface_get_surface + function fl_surface_device_get_surface return Storage.Integer_Address; - pragma Import (C, fl_surface_get_surface, "fl_surface_get_surface"); - pragma Inline (fl_surface_get_surface); + pragma Import (C, fl_surface_device_get_surface, "fl_surface_device_get_surface"); + pragma Inline (fl_surface_device_get_surface); - procedure fl_surface_set_driver + function fl_surface_device_get_driver + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_surface_device_get_driver, "fl_surface_device_get_driver"); + pragma Inline (fl_surface_device_get_driver); + + procedure fl_surface_device_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); + pragma Import (C, fl_surface_device_set_driver, "fl_surface_device_set_driver"); + pragma Inline (fl_surface_device_set_driver); @@ -54,7 +60,7 @@ package body FLTK.Devices.Surface is (This : in out Surface_Device) is begin if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_surface (This.Void_Ptr); + free_fl_surface_device (This.Void_Ptr); This.Void_Ptr := Null_Pointer; end if; end Finalize; @@ -73,7 +79,7 @@ package body FLTK.Devices.Surface is return Surface_Device is begin return This : Surface_Device do - This.Void_Ptr := new_fl_surface (Wrapper (Graphics).Void_Ptr); + This.Void_Ptr := new_fl_surface_device (Wrapper (Graphics).Void_Ptr); This.My_Driver := Graphics'Unchecked_Access; end return; end Create; @@ -87,7 +93,9 @@ package body FLTK.Devices.Surface is -- Static Attributes -- ------------------------- - Original_Surface : aliased Surface_Device; + Original_Surface : aliased Surface_Device; + Original_Graphics : aliased FLTK.Devices.Graphics.Graphics_Driver; + Current_Surface : access Surface_Device'Class := Original_Surface'Access; @@ -114,7 +122,7 @@ package body FLTK.Devices.Surface is procedure Set_Current (This : in out Surface_Device) is begin - fl_surface_set_current (This.Void_Ptr); + fl_surface_device_set_current (This.Void_Ptr); This.Set_Current_Bookkeep; end Set_Current; @@ -149,7 +157,7 @@ package body FLTK.Devices.Surface is (This : in out Surface_Device; Driver : in out FLTK.Devices.Graphics.Graphics_Driver'Class) is begin - fl_surface_set_driver (This.Void_Ptr, Wrapper (Driver).Void_Ptr); + fl_surface_device_set_driver (This.Void_Ptr, Wrapper (Driver).Void_Ptr); This.My_Driver := Driver'Unchecked_Access; end Set_Driver; @@ -157,9 +165,15 @@ package body FLTK.Devices.Surface is begin - Original_Surface.Void_Ptr := fl_surface_get_surface; + Original_Surface.Void_Ptr := fl_surface_device_get_surface; Original_Surface.Needs_Dealloc := False; + Wrapper (Original_Graphics).Void_Ptr := + fl_surface_device_get_driver (Original_Surface.Void_Ptr); + Wrapper (Original_Graphics).Needs_Dealloc := False; + + Original_Surface.My_Driver := Original_Graphics'Access; + end FLTK.Devices.Surface; diff --git a/src/fltk-devices-surface.ads b/src/fltk-devices-surface.ads index 68d0df7..f70d1e8 100644 --- a/src/fltk-devices-surface.ads +++ b/src/fltk-devices-surface.ads @@ -12,9 +12,6 @@ with 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 |