render: Introduce render context object.

Due to the declarative modules feature of Guile 2.9.4+, the existing
technique of using one top-level variable per GL state was very broken
because the initial values got cached at all call sites and state
updates were being silently ignored and thus the game window was
always a black screen.  Not good!  By replacing all of the state
variables with a single "context" object and poking at fields inside,
things work again and it's arguably the better design anyhow.

1 files changed, 43 insertions, 60 deletions

diff --git a/chickadee/render.scm b/chickadee/render.scm
index 5b95d1b..f502369 100644
--- a/chickadee/render.scm
+++ b/chickadee/render.scm
@@ -30,6 +30,7 @@
   #:use-module (chickadee render texture)
   #:use-module (chickadee render buffer)
   #:use-module (chickadee render viewport)
+  #:use-module (srfi srfi-9)
   #:export (current-viewport
             current-framebuffer
             current-blend-mode
@@ -47,43 +48,55 @@
             gpu-apply/instanced*
             gpu-apply/instanced))
 
-(define *current-viewport* null-viewport)
-(define *current-framebuffer* null-framebuffer)
-(define *current-blend-mode* 'replace)
-(define *current-depth-test* #f)
-(define *current-projection* (make-identity-matrix4))
-(define *current-textures* (make-vector 32 null-texture))
+(define-record-type <render-context>
+  (make-render-context viewport framebuffer blend-mode depth-test?
+                        projection textures)
+  render-context?
+  (viewport render-context-viewport set-render-context-viewport!)
+  (framebuffer render-context-framebuffer set-render-context-framebuffer!)
+  (blend-mode render-context-blend-mode set-render-context-blend-mode!)
+  (depth-test? render-context-depth-test? set-render-context-depth-test!)
+  (projection render-context-projection set-render-context-projection!)
+  (textures render-context-textures))
+
+(define render-context
+  (make-render-context null-viewport
+                       null-framebuffer
+                       'replace
+                       #f
+                       (make-identity-matrix4)
+                       (make-vector 32 null-texture)))
 
 (define (current-viewport)
-  *current-viewport*)
+  (render-context-viewport render-context))
 
 (define (current-framebuffer)
-  *current-framebuffer*)
+  (render-context-framebuffer render-context))
 
 (define (current-blend-mode)
-  *current-blend-mode*)
+  (render-context-blend-mode render-context))
 
 (define (current-depth-test)
-  *current-depth-test*)
+  (render-context-depth-test? render-context))
 
 (define (current-texture i)
-  (vector-ref *current-textures* i))
+  (vector-ref (render-context-textures render-context) i))
 
 (define (current-projection)
-  *current-projection*)
+  (render-context-projection render-context))
 
-(define-syntax-rule (with (name value) body ...)
-  (let ((prev name))
-    (dynamic-wind
-      (lambda () (set! name value))
-      (lambda () body ...)
-      (lambda () (set! name prev)))))
+(define-syntax-rule (with (getter setter value) body ...)
+  (let ((prev (getter render-context)))
+    (setter render-context value)
+    body ...
+    (setter render-context prev)))
 
 (define-syntax-rule (with-viewport viewport body ...)
-  (with (*current-viewport* viewport) body ...))
+  (with (render-context-viewport set-render-context-viewport! viewport)
+        body ...))
 
 (define-syntax-rule (with-framebuffer framebuffer body ...)
-  (with (*current-framebuffer* framebuffer)
+  (with (render-context-framebuffer set-render-context-framebuffer! framebuffer)
         ;; As a convenience, initialize the viewport and projection
         ;; matrix as well so that the user doesn't have to explicitly
         ;; make a viewport and/or projection matrix unless they
@@ -93,54 +106,24 @@
             body ...))))
 
 (define-syntax-rule (with-blend-mode blend-mode body ...)
-  (with (*current-blend-mode* blend-mode) body ...))
+  (with (render-context-blend-mode set-render-context-blend-mode! blend-mode)
+        body ...))
 
 (define-syntax-rule (with-depth-test depth-test body ...)
-  (with (*current-depth-test* depth-test) body ...))
+  (with (render-context-depth-test? set-render-context-depth-test! depth-test)
+        body ...))
 
 (define-syntax-rule (with-texture n texture body ...)
-  (let ((prev (vector-ref *current-textures* n)))
+  (let* ((textures (render-context-textures render-context))
+         (prev (vector-ref textures n)))
     (dynamic-wind
-      (lambda () (vector-set! *current-textures* n texture))
+      (lambda () (vector-set! textures n texture))
       (lambda () body ...)
-      (lambda () (vector-set! *current-textures* n prev)))))
-
-(define-syntax-rule (with-shader shader body ...)
-  (with (*current-shader* shader)
-        (initialize-uniforms)
-        body ...))
-
-(define-syntax-rule (with-vertex-array vertex-array body ...)
-  (with (*current-vertex-array* vertex-array) body ...))
+      (lambda () (vector-set! textures n prev)))))
 
 (define-syntax-rule (with-projection matrix body ...)
-  (with (*current-projection* matrix) body ...))
-
-;; (define (initialize-uniforms)
-;;   (hash-for-each (lambda (name uniform)
-;;                    (unless (hash-get-handle *current-uniforms* name)
-;;                      (hash-set! *current-uniforms* name
-;;                                 (uniform-default-value uniform))))
-;;                  (shader-uniforms *current-shader*)))
-
-;; (define-syntax uniform-let
-;;   (syntax-rules ()
-;;     ((_ () body ...) (begin body ...))
-;;     ((_ ((name value) . rest) body ...)
-;;      (let ((uniform (shader-uniform (current-shader) name))
-;;            (prev (hash-ref *current-uniforms* name)))
-;;        (if uniform
-;;            (dynamic-wind
-;;              (lambda ()
-;;                (hash-set! *current-uniforms* name value))
-;;              (lambda ()
-;;                (uniform-let rest body ...))
-;;              (lambda ()
-;;                (hash-set! *current-uniforms* name prev)))
-;;            (error "no such uniform: " name))))))
-
-;; (define (uniform-ref name)
-;;   (uniform-value (shader-uniform (current-shader) name)))
+  (with (render-context-projection set-render-context-projection! matrix)
+        body ...))
 
 (define (keyword->string kw)
   (symbol->string (keyword->symbol kw)))