Reap OpenGL textures when texture objects are GC'd.

1 files changed, 22 insertions, 3 deletions

diff --git a/2d/texture.scm b/2d/texture.scm
index 7a3a60d..9f53966 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -43,6 +43,23 @@
   (width texture-width)
   (height texture-height))
 
+;; Use a guardian and an after GC hook that ensures that OpenGL
+;; textures are deleted when texture objects are GC'd.
+(define texture-guardian (make-guardian))
+
+(define (reap-textures)
+  (let loop ((texture (texture-guardian)))
+    (when texture
+      ;; When attempting to reap structures upon guile exit, the
+      ;; dynamic pointer to gl-delete-textures becomes invalid. So, we
+      ;; ignore the error and move on.
+      (catch 'misc-error
+        (lambda () (gl-delete-textures (list (texture-id texture))))
+        (lambda (key . args) #f))
+      (loop (texture-guardian)))))
+
+(add-hook! after-gc-hook reap-textures)
+
 (define (surface-pixel-format surface)
   "Returns the OpenGL pixel format for a surface. RGB and RGBA formats
 are supported."
@@ -72,9 +89,11 @@ Currently only works with RGBA format surfaces."
                            pixel-format
                            (color-pointer-type unsigned-byte)
                            (SDL:surface-pixels surface)))
-    (make-texture texture-id
-                  (SDL:surface:w surface)
-                  (SDL:surface:h surface))))
+    (let ((texture (make-texture texture-id
+                                 (SDL:surface:w surface)
+                                 (SDL:surface:h surface))))
+      (texture-guardian texture)
+      texture)))
 
 (define (load-texture filename)
   "Loads a texture from a file."