Completed Fl_Surface_Device binding

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 @@
     <td>Device</td>
   </tr>
 
+  <tr>
+    <td>&nbsp;</td>
+    <td>Device_Reference</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Static Attributes</th></tr>
+
+  <tr>
+<td><pre>
+static const char * class_id = "Fl_Device";
+</pre></td>
+<td>Use runtime tag checks instead</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Functions and Procedures</th></tr>
+
+  <tr>
+<td><pre>
+virtual const char * class_name();
+</pre></td>
+<td>Deprecated, use runtime tag checks instead</td>
+  </tr>
+
 </table>
 
 
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 @@
 
 
 <table class="function">
-  <tr><th colspan="2">Functions and Procedures</th></tr>
+  <tr><th colspan="2">Static Attributes</th></tr>
+
+  <tr>
+<td><pre>
+static const char * class_id = "Fl_Surface_Device";
+</pre></td>
+<td>Use runtime tag checks instead</td>
+  </tr>
+
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Constructors</th></tr>
 
   <tr>
 <td><pre>
@@ -54,11 +68,18 @@ Fl_Surface_Device(Fl_Graphics_Driver *graphics_driver);
 </pre></td>
 <td><pre>
 function Create
-       (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver)
+       (Graphics : in FLTK.Devices.Graphics.Graphics_Driver)
     return Surface_Device;
 </pre></td>
   </tr>
 
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Functions and Procedures</th></tr>
+
   <tr>
 <td><pre>
 const char * class_name();
@@ -68,16 +89,28 @@ const char * class_name();
 
   <tr>
 <td><pre>
-void driver(Fl_Graphics_Driver *graphics_driver);
+Fl_Graphics_Driver * driver();
+</pre></td>
+<td><pre>
+function Has_Driver
+       (This : in Surface_Device)
+    return Boolean;
+
+function Get_Driver
+       (This : in out Surface_Device)
+    return FLTK.Devices.Graphics.Graphics_Driver_Reference;
 </pre></td>
-<td>TBA</td>
   </tr>
 
   <tr>
 <td><pre>
-Fl_Graphics_Driver * driver();
+void driver(Fl_Graphics_Driver *graphics_driver);
+</pre></td>
+<td><pre>
+procedure Set_Driver
+       (This   : in out Surface_Device;
+        Driver : in     FLTK.Devices.Graphics.Graphics_Driver'Class);
 </pre></td>
-<td>TBA</td>
   </tr>
 
   <tr>
@@ -90,13 +123,23 @@ procedure Set_Current
 </pre></td>
   </tr>
 
+</table>
+
+
+
+<table class="function">
+  <tr><th colspan="2">Static Functions and Procedures</th></tr>
+
   <tr>
 <td><pre>
 static Fl_Surface_Device * surface();
 </pre></td>
 <td><pre>
 function Get_Current
-    return access Surface_Device'Class;
+    return Surface_Device_Reference;
+
+function Get_Original
+    return Surface_Device_Reference;
 </pre></td>
   </tr>
 
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<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