render: shader: Move shader loading helper procedures out of top level.

1 files changed, 115 insertions, 126 deletions

diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index 91d363c..6eeb76d 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -228,135 +228,33 @@
 
 (define *shader-state* (make-gpu-state apply-shader null-shader))
 
-(define (shader-compiled? id)
-  (let ((status (make-u32vector 1)))
-    (gl-get-shaderiv id (version-2-0 compile-status)
-                     (bytevector->pointer status))
-    (= (u32vector-ref status 0) 1)))
-
-(define (shader-linked? id)
-  (let ((status (make-u32vector 1)))
-    (gl-get-programiv id (version-2-0 link-status)
-                      (bytevector->pointer status))
-    (= (u32vector-ref status 0) 1)))
-
-(define (info-log length-proc log-proc id)
-  (let ((log-length-bv (make-u32vector 1)))
-    (length-proc id (version-2-0 info-log-length)
-                 (bytevector->pointer log-length-bv))
-    (u32vector-ref log-length-bv 0)
-    ;; Add one byte to account for the null string terminator.
-    (let* ((log-length (u32vector-ref log-length-bv 0))
-           (log (make-u8vector (1+ log-length))))
-      (log-proc id log-length %null-pointer (bytevector->pointer log))
-      (utf8->string log))))
-
-(define (compilation-error id)
-  (info-log gl-get-shaderiv gl-get-shader-info-log id))
-
-(define (linking-error id)
-  (info-log gl-get-programiv gl-get-program-info-log id))
-
-(define (uniform-count id)
-  (let ((bv (make-u32vector 1)))
-    (gl-get-programiv id
-                      (arb-shader-objects active-uniforms)
-                      (bytevector->pointer bv))
-    (u32vector-ref bv 0)))
-
-(define (utf8->string* bv length)
-  (let ((bv* (make-bytevector length)))
-    (bytevector-copy! bv 0 bv* 0 length)
-    (utf8->string bv*)))
-
-(define (parse-data-type type)
-  (cond
-   ((= type (version-2-0 bool)) %bool)
-   ((= type (data-type int)) %int)
-   ((= type (data-type unsigned-int)) %unsigned-int)
-   ((= type (data-type float)) %float)
-   ((= type (version-2-0 float-vec2)) %float-vec2)
-   ((= type (version-2-0 float-vec3)) %float-vec3)
-   ((= type (version-2-0 float-vec4)) %float-vec4)
-   ((= type (version-2-0 float-mat4)) %mat4)
-   ((= type (version-2-0 sampler-2d)) %sampler-2d)
-   (else
-    (error "unsupported OpenGL type" type))))
-
-(define (extract-uniforms id)
-  (let ((total (uniform-count id))
-        (table (make-hash-table)))
-    (let loop ((i 0)
-               (texture-unit 0))
-      (unless (= i total)
-        (let ((length-bv (make-u32vector 1))
-              (size-bv (make-u32vector 1))
-              (type-bv (make-u32vector 1))
-              (name-bv (make-bytevector 255)))
-          (gl-get-active-uniform id i
-                                 (bytevector-length name-bv)
-                                 (bytevector->pointer length-bv)
-                                 (bytevector->pointer size-bv)
-                                 (bytevector->pointer type-bv)
-                                 (bytevector->pointer name-bv))
-          (let* ((name-length (u32vector-ref length-bv 0))
-                 (name (utf8->string* name-bv name-length))
-                 (location (gl-get-uniform-location id name))
-                 (size (u32vector-ref size-bv 0))
-                 (type (parse-data-type (u32vector-ref type-bv 0)))
-                 (sampler? (eq? type %sampler-2d))
-                 (default (if sampler?
-                              texture-unit
-                              (shader-data-type-null type))))
-            ;; TODO: Handle uniform arrays.
-            (unless (= size 1)
-              (error "unsupported uniform size" name size))
-            (hash-set! table
-                       name
-                       (make-uniform name location type default))
-            (loop (1+ i)
-                  (if sampler?
-                      (1+ texture-unit)
-                      texture-unit))))))
-    table))
-
-(define (attribute-count id)
-  (let ((bv (make-u32vector 1)))
-    (gl-get-programiv id
-                      (arb-shader-objects active-attributes)
-                      (bytevector->pointer bv))
-    (u32vector-ref bv 0)))
-
-(define (extract-attributes id)
-  (let ((total (attribute-count id))
-        (table (make-hash-table)))
-    (let loop ((i 0))
-      (unless (= i total)
-        (let ((length-bv (make-u32vector 1))
-              (size-bv (make-u32vector 1))
-              (type-bv (make-u32vector 1))
-              (name-bv (make-bytevector 255)))
-          (gl-get-active-attrib id i
-                                (bytevector-length name-bv)
-                                (bytevector->pointer length-bv)
-                                (bytevector->pointer size-bv)
-                                (bytevector->pointer type-bv)
-                                (bytevector->pointer name-bv))
-          (let* ((length (u32vector-ref length-bv 0))
-                 (name (utf8->string* name-bv length))
-                 (size (u32vector-ref size-bv 0))
-                 (type (parse-data-type (u32vector-ref type-bv 0)))
-                 (location (gl-get-attrib-location id name)))
-            (unless (= size 1)
-              (error "unsupported attribute size" name size))
-
-            (hash-set! table name (make-attribute name location type))))
-        (loop (1+ i))))
-    table))
-
 (define (make-shader vertex-port fragment-port)
   "Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile
 them into a GPU shader program."
+  (define (shader-compiled? id)
+    (let ((status (make-u32vector 1)))
+      (gl-get-shaderiv id (version-2-0 compile-status)
+                       (bytevector->pointer status))
+      (= (u32vector-ref status 0) 1)))
+  (define (shader-linked? id)
+    (let ((status (make-u32vector 1)))
+      (gl-get-programiv id (version-2-0 link-status)
+                        (bytevector->pointer status))
+      (= (u32vector-ref status 0) 1)))
+  (define (info-log length-proc log-proc id)
+    (let ((log-length-bv (make-u32vector 1)))
+      (length-proc id (version-2-0 info-log-length)
+                   (bytevector->pointer log-length-bv))
+      (u32vector-ref log-length-bv 0)
+      ;; Add one byte to account for the null string terminator.
+      (let* ((log-length (u32vector-ref log-length-bv 0))
+             (log (make-u8vector (1+ log-length))))
+        (log-proc id log-length %null-pointer (bytevector->pointer log))
+        (utf8->string log))))
+  (define (compilation-error id)
+    (info-log gl-get-shaderiv gl-get-shader-info-log id))
+  (define (linking-error id)
+    (info-log gl-get-programiv gl-get-program-info-log id))
   (define (make-shader-stage type port)
     (let ((id (gl-create-shader type))
           (source (get-bytevector-all port)))
@@ -372,6 +270,97 @@ them into a GPU shader program."
           (gl-delete-shader id) ; clean up GPU resource.
           (error "failed to compile shader" error-log)))
       id))
+  (define (uniform-count id)
+    (let ((bv (make-u32vector 1)))
+      (gl-get-programiv id
+                        (arb-shader-objects active-uniforms)
+                        (bytevector->pointer bv))
+      (u32vector-ref bv 0)))
+  (define (utf8->string* bv length)
+    (let ((bv* (make-bytevector length)))
+      (bytevector-copy! bv 0 bv* 0 length)
+      (utf8->string bv*)))
+  (define (parse-data-type type)
+    (cond
+     ((= type (version-2-0 bool)) %bool)
+     ((= type (data-type int)) %int)
+     ((= type (data-type unsigned-int)) %unsigned-int)
+     ((= type (data-type float)) %float)
+     ((= type (version-2-0 float-vec2)) %float-vec2)
+     ((= type (version-2-0 float-vec3)) %float-vec3)
+     ((= type (version-2-0 float-vec4)) %float-vec4)
+     ((= type (version-2-0 float-mat4)) %mat4)
+     ((= type (version-2-0 sampler-2d)) %sampler-2d)
+     (else
+      (error "unsupported OpenGL type" type))))
+  (define (extract-uniforms id)
+    (let ((total (uniform-count id))
+          (table (make-hash-table)))
+      (let loop ((i 0)
+                 (texture-unit 0))
+        (unless (= i total)
+          (let ((length-bv (make-u32vector 1))
+                (size-bv (make-u32vector 1))
+                (type-bv (make-u32vector 1))
+                (name-bv (make-bytevector 255)))
+            (gl-get-active-uniform id i
+                                   (bytevector-length name-bv)
+                                   (bytevector->pointer length-bv)
+                                   (bytevector->pointer size-bv)
+                                   (bytevector->pointer type-bv)
+                                   (bytevector->pointer name-bv))
+            (let* ((name-length (u32vector-ref length-bv 0))
+                   (name (utf8->string* name-bv name-length))
+                   (location (gl-get-uniform-location id name))
+                   (size (u32vector-ref size-bv 0))
+                   (type (parse-data-type (u32vector-ref type-bv 0)))
+                   (sampler? (eq? type %sampler-2d))
+                   (default (if sampler?
+                                texture-unit
+                                (shader-data-type-null type))))
+              ;; TODO: Handle uniform arrays.
+              (unless (= size 1)
+                (error "unsupported uniform size" name size))
+              (hash-set! table
+                         name
+                         (make-uniform name location type default))
+              (loop (1+ i)
+                    (if sampler?
+                        (1+ texture-unit)
+                        texture-unit))))))
+      table))
+  (define (attribute-count id)
+    (let ((bv (make-u32vector 1)))
+      (gl-get-programiv id
+                        (arb-shader-objects active-attributes)
+                        (bytevector->pointer bv))
+      (u32vector-ref bv 0)))
+  (define (extract-attributes id)
+    (let ((total (attribute-count id))
+          (table (make-hash-table)))
+      (let loop ((i 0))
+        (unless (= i total)
+          (let ((length-bv (make-u32vector 1))
+                (size-bv (make-u32vector 1))
+                (type-bv (make-u32vector 1))
+                (name-bv (make-bytevector 255)))
+            (gl-get-active-attrib id i
+                                  (bytevector-length name-bv)
+                                  (bytevector->pointer length-bv)
+                                  (bytevector->pointer size-bv)
+                                  (bytevector->pointer type-bv)
+                                  (bytevector->pointer name-bv))
+            (let* ((length (u32vector-ref length-bv 0))
+                   (name (utf8->string* name-bv length))
+                   (size (u32vector-ref size-bv 0))
+                   (type (parse-data-type (u32vector-ref type-bv 0)))
+                   (location (gl-get-attrib-location id name)))
+              (unless (= size 1)
+                (error "unsupported attribute size" name size))
+
+              (hash-set! table name (make-attribute name location type))))
+          (loop (1+ i))))
+      table))
   (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
                                       vertex-port))
         (fragment-id (make-shader-stage (version-2-0 fragment-shader)