Add define-guardian macro.

* 2d/helpers.scm (define-guardian): New macro.
* 2d/texture.scm (reap-textures): Delete it.
  (texture-guardian): Defined using define-guardian.

2 files changed, 30 insertions, 17 deletions

diff --git a/2d/helpers.scm b/2d/helpers.scm
index 142161a..a9d2dfe 100644
--- a/2d/helpers.scm
+++ b/2d/helpers.scm
@@ -24,8 +24,11 @@
 (define-module (2d helpers)
   #:use-module (srfi srfi-1)
   #:use-module (rnrs arithmetic bitwise)
+  #:use-module (2d agenda)
+  #:use-module (2d game)
   #:export (any-equal?
-            logand?))
+            logand?
+            define-guardian))
 
 (define (any-equal? elem . args)
   "Return #t if ELEM equals any of the elements in the list ARGS."
@@ -35,3 +38,21 @@
   "Return #t if the result of a bitwise AND of the integers in list
 ARGS is non-zero."
   (not (zero? (apply logand args))))
+
+(define-syntax-rule (define-guardian name reaper)
+  "Define a new guardian called NAME and call REAPER when an object
+within the guardian is GC'd.  Reaping is ensured to happen from the
+same thread that is running the game loop."
+  (begin
+    (define name (make-guardian))
+    (add-hook! after-gc-hook
+               (lambda ()
+                 (define (reap)
+                   (let ((obj (name)))
+                     (when obj
+                       (reaper obj)
+                       (reap))))
+                 ;; Scheduling the reaping procedure in the game
+                 ;; loop's agenda ensures that the reaping will be
+                 ;; done in the main thread.
+                 (schedule game-agenda reap)))))
diff --git a/2d/texture.scm b/2d/texture.scm
index daa0568..faa2359 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -93,22 +93,14 @@ that will be rendered, in pixels."
 
 ;; 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
-      ;; Do not reap texture regions
-      (unless (texture-region? 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-texture (texture-id texture)))
-          (lambda (key . args) #f)))
-      (loop (texture-guardian)))))
-
-(add-hook! after-gc-hook reap-textures)
+(define-guardian texture-guardian
+  (lambda (texture)
+    ;; Do not reap texture regions
+    (unless (texture-region? 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.
+      (false-if-exception (gl-delete-texture (texture-id texture))))))
 
 (define (bitmap->texture bitmap)
   "Translates a freeimage bitmap into an OpenGL texture."