render: shader: Add support for shader structs.

2 files changed, 490 insertions, 147 deletions

diff --git a/chickadee/render.scm b/chickadee/render.scm
index b898cb5..edf21f7 100644
--- a/chickadee/render.scm
+++ b/chickadee/render.scm
@@ -133,10 +133,10 @@
     (syntax-case x ()
       ((_ shader ()) (datum->syntax x #t))
       ((_ shader (name value . rest))
-       (with-syntax ((sname (datum->syntax x (keyword->string
+       (with-syntax ((sname (datum->syntax x (keyword->symbol
                                               (syntax->datum #'name)))))
          #'(begin
-             (shader-uniform-set! shader sname value)
+             (shader-uniform-set! shader 'sname value)
              (uniform-apply shader rest)))))))
 
 (define-syntax-rule (gpu-prepare shader vertex-array uniforms)
@@ -157,10 +157,11 @@
     ;; Sampler2D values aren't explicitly passed as uniform values via
     ;; gpu-apply, so we have to set their values correctly behind the
     ;; scenes.
-    (hash-for-each (lambda (name uniform)
-                     (when (eq? 'sampler-2d (uniform-type uniform))
-                       (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform))))
-                   (shader-uniforms shader))))
+    (uniform-namespace-for-each
+     (lambda (name uniform)
+       (when (and (uniform? uniform) (eq? 'sampler-2d (uniform-type uniform)))
+         (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform))))
+     (shader-uniforms shader))))
 
 (define-syntax-rule (gpu-apply* shader vertex-array count . uniforms)
   (begin
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index e3b80c9..19f1f3c 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -1,5 +1,5 @@
 ;;; Chickadee Game Toolkit
-;;; Copyright © 2016 David Thompson <davet@gnu.org>
+;;; Copyright © 2016, 2019 David Thompson <davet@gnu.org>
 ;;;
 ;;; Chickadee is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published
@@ -16,8 +16,11 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (chickadee render shader)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 regex)
   #:use-module (oop goops)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
@@ -33,7 +36,21 @@
   #:use-module (chickadee render gl)
   #:use-module (chickadee render gpu)
   #:use-module (chickadee render texture)
-  #:export (make-shader
+  #:export (shader-data-type?
+            bool
+            int
+            unsigned-int
+            float
+            float-vec2
+            float-vec3
+            float-vec4
+            mat4
+            sampler-2d
+            uniform-namespace?
+            uniform-namespace-ref
+            uniform-namespace-for-each
+            define-shader-type
+            make-shader
             shader?
             null-shader
             load-shader
@@ -58,16 +75,25 @@
 ;;;
 
 (define-record-type <shader-data-type>
-  (%make-shader-data-type name size serializer setter null)
+  (%make-shader-data-type name size validator serializer setter null)
   shader-data-type?
   (name shader-data-type-name)
   (size shader-data-type-size)
+  (validator shader-data-type-validator)
   (serializer shader-data-type-serializer)
   (setter shader-data-type-setter)
   (null shader-data-type-null))
 
-(define* (make-shader-data-type #:key name size serializer setter null)
-  (%make-shader-data-type name size serializer setter null))
+(define (display-shader-data-type type port)
+  (format port "#<shader-data-type name: ~a size: ~d null: ~a>"
+          (shader-data-type-name type)
+          (shader-data-type-size type)
+          (shader-data-type-null type)))
+
+(set-record-type-printer! <shader-data-type> display-shader-data-type)
+
+(define* (make-shader-data-type #:key name size validator serializer setter null)
+  (%make-shader-data-type name size validator serializer setter null))
 
 (define (shader-data-type-serialize type bv data)
   (let ((serialize (shader-data-type-serializer type)))
@@ -82,107 +108,262 @@
 (define (shader-data-type-apply-uniform type location count pointer)
   ((shader-data-type-setter type) location count pointer))
 
+(define (shader-data-type-validate type data)
+  (let ((valid? (shader-data-type-validator type)))
+    (if (vector? data)
+        (let loop ((i 0))
+          (if (and (< i (vector-length data))
+                   (valid? (vector-ref data i)))
+              (loop (+ i 1))
+              #t))
+        (valid? data))))
+
+(define-syntax-rule (define-shader-data-type var . args)
+  (define var (make-shader-data-type . args)))
+
 ;; Primitive types:
-(define %bool
-  (make-shader-data-type
-   #:name 'bool
-   #:size 4
-   #:serializer
-   (lambda (bv i bool)
-     (bytevector-s32-native-set! bv i (if bool 1 0)))
-   #:setter gl-uniform1iv
-   #:null #false))
-
-(define %int
-  (make-shader-data-type
-   #:name 'int
-   #:size 4
-   #:serializer
-   (lambda (bv i n)
-     (bytevector-s32-native-set! bv i n))
-   #:setter gl-uniform1iv
-   #:null 0))
-
-(define %unsigned-int
-  (make-shader-data-type
-   #:name 'unsigned-int
-   #:size 4
-   #:serializer
-   (lambda (bv i u)
-     (bytevector-u32-native-set! bv i u))
-   #:setter gl-uniform1uiv
-   #:null 0))
-
-(define %float
-  (make-shader-data-type
-   #:name 'float
-   #:size 4
-   #:serializer
-   (lambda (bv i f)
-     (bytevector-ieee-single-native-set! bv i f))
-   #:setter gl-uniform1fv
-   #:null 0.0))
-
-(define %float-vec2
-  (make-shader-data-type
-   #:name 'float-vec2
-   #:size 8 ; 8 bytes = 2 floats = 1 vec2
-   #:serializer
-   (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2)))
-     (lambda (bv i v)
-       (bytevector-copy! (unwrap-vec2 v) 0 bv i 8)))
-   #:setter gl-uniform2fv
-   #:null (vec2 0.0 0.0)))
-
-(define %float-vec3
-  (make-shader-data-type
-   #:name 'float-vec3
-   #:size 12 ; 12 bytes = 3 floats = 1 vec3
-   #:serializer
-   (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3)))
-     (lambda (bv i v)
-       (bytevector-copy! (unwrap-vec3 v) 0 bv i 12)))
-   #:setter gl-uniform3fv
-   #:null (vec3 0.0 0.0 0.0)))
-
-(define %float-vec4
-  (make-shader-data-type
-   #:name 'float-vec4
-   #:size 16 ; 16 bytes = 4 floats = 1 vec4
-   #:serializer
-   (lambda (bv i v)
-     ;; As of now, there is no vec4 Scheme type, but we do want to
-     ;; accept colors as vec4s since there is no special color type in
-     ;; GLSL.
-     (bytevector-ieee-single-native-set! bv i (color-r v))
-     (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v))
-     (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v))
-     (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v)))
-   #:setter gl-uniform4fv
-   #:null (color 0.0 0.0 0.0 0.0)))
-
-(define %mat4
-  (make-shader-data-type
-   #:name 'mat4
-   #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
-   #:serializer
-   (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv)))
-     (lambda (bv i m)
-       ;; 4 rows x 4 columns x 4 bytes per float = 4^3
-       (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4))))
-   #:setter (lambda (location count ptr)
-              (gl-uniform-matrix4fv location count #f ptr))
-   #:null (make-identity-matrix4)))
-
-(define %sampler-2d
-  (make-shader-data-type
-   #:name 'sampler-2d
-   #:size 4
-   #:serializer
-   (lambda (bv i texture-unit)
-     (bytevector-s32-native-set! bv i texture-unit))
-   #:setter gl-uniform1iv
-   #:null 0))
+(define-shader-data-type bool
+  #:name 'bool
+  #:size 4
+  #:validator boolean?
+  #:serializer
+  (lambda (bv i bool)
+    (bytevector-s32-native-set! bv i (if bool 1 0)))
+  #:setter gl-uniform1iv
+  #:null #false)
+
+(define-shader-data-type int
+  #:name 'int
+  #:size 4
+  #:validator integer?
+  #:serializer
+  (lambda (bv i n)
+    (bytevector-s32-native-set! bv i n))
+  #:setter gl-uniform1iv
+  #:null 0)
+
+(define-shader-data-type unsigned-int
+  #:name 'unsigned-int
+  #:size 4
+  #:validator
+  (lambda (i)
+    (and (integer? i) (>= i 0)))
+  #:serializer
+  (lambda (bv i u)
+    (bytevector-u32-native-set! bv i u))
+  #:setter gl-uniform1uiv
+  #:null 0)
+
+(define-shader-data-type float
+  #:name 'float
+  #:size 4
+  #:validator number?
+  #:serializer
+  (lambda (bv i f)
+    (bytevector-ieee-single-native-set! bv i f))
+  #:setter gl-uniform1fv
+  #:null 0.0)
+
+(define-shader-data-type float-vec2
+  #:name 'float-vec2
+  #:size 8 ; 8 bytes = 2 floats = 1 vec2
+  #:validator vec2?
+  #:serializer
+  (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2)))
+    (lambda (bv i v)
+      (bytevector-copy! (unwrap-vec2 v) 0 bv i 8)))
+  #:setter gl-uniform2fv
+  #:null (vec2 0.0 0.0))
+
+(define-shader-data-type float-vec3
+  #:name 'float-vec3
+  #:size 12 ; 12 bytes = 3 floats = 1 vec3
+  #:validator vec3?
+  #:serializer
+  (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3)))
+    (lambda (bv i v)
+      (bytevector-copy! (unwrap-vec3 v) 0 bv i 12)))
+  #:setter gl-uniform3fv
+  #:null (vec3 0.0 0.0 0.0))
+
+(define-shader-data-type float-vec4
+  #:name 'float-vec4
+  #:size 16 ; 16 bytes = 4 floats = 1 vec4
+  #:validator color?
+  #:serializer
+  (lambda (bv i v)
+    ;; As of now, there is no vec4 Scheme type, but we do want to
+    ;; accept colors as vec4s since there is no special color type in
+    ;; GLSL.
+    (bytevector-ieee-single-native-set! bv i (color-r v))
+    (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v))
+    (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v))
+    (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v)))
+  #:setter gl-uniform4fv
+  #:null (color 0.0 0.0 0.0 0.0))
+
+(define-shader-data-type mat4
+  #:name 'mat4
+  #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
+  #:validator matrix4?
+  #:serializer
+  (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv)))
+    (lambda (bv i m)
+      ;; 4 rows x 4 columns x 4 bytes per float = 4^3
+      (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4))))
+  #:setter (lambda (location count ptr)
+             (gl-uniform-matrix4fv location count #f ptr))
+  #:null (make-identity-matrix4))
+
+(define-shader-data-type sampler-2d
+  #:name 'sampler-2d
+  #:size 4
+  #:validator integer?
+  #:serializer
+  (lambda (bv i texture-unit)
+    (bytevector-s32-native-set! bv i texture-unit))
+  #:setter gl-uniform1iv
+  #:null 0)
+
+
+;;;
+;;; Shader Structs
+;;;
+
+;; A meta-vtable that has two additional slots: one for the struct
+;; name, and another for the lookup table that maps struct field names
+;; to their respective struct index and shader data type.
+(define <shader-struct>
+  (make-vtable (string-append standard-vtable-fields "pwpw")
+               (lambda (vt port)
+                 (format port "#<shader-struct ~a>"
+                         (shader-struct-fields vt)))))
+
+(define (shader-struct? struct)
+  (eq? (struct-vtable (struct-vtable struct)) <shader-struct>))
+
+(define shader-struct-name-index vtable-offset-user)
+(define shader-struct-fields-index (+ vtable-offset-user 1))
+
+(define (shader-struct-name vtable)
+  (struct-ref vtable shader-struct-name-index))
+
+(define (shader-struct-fields vtable)
+  (struct-ref vtable shader-struct-fields-index))
+
+(define (shader-struct-type-check vtable field value)
+  (match (assq-ref (shader-struct-fields vtable) field)
+    ((_ type size)
+     (define (validate value)
+       (unless (or (and (struct? value) (eq? (struct-vtable value) type))
+                   (shader-data-type-validate type value))
+         (error "invalid type for shader struct field" field value)))
+     (cond
+      ((= size 1)
+       (validate value))
+      ((and (vector? value)
+            (= (vector-length value) size))
+       (let loop ((i 0))
+         (when (< i (vector-length value))
+           (validate (vector-ref value i))
+           (loop (+ i 1)))))
+      ((vector? value)
+       (error "incorrect vector size" value))
+      (else
+       (error "expected vector, got" value))))))
+
+(define (shader-struct-default vtable field)
+  (match (assq-ref (shader-struct-fields vtable) field)
+    ((_ type size)
+     (let ((default (if (eq? (struct-vtable type) <shader-struct>)
+                        (apply make-struct/no-tail type
+                               (map (match-lambda
+                                      ((sub-field _ _ _)
+                                       (shader-struct-default type sub-field)))
+                                    (shader-struct-fields type)))
+                        (shader-data-type-null type))))
+       (if (= size 1)
+           default
+           (make-vector size default))))))
+
+(define (make-shader-struct-field-table fields+types)
+  ;; Map field names to their struct indices and shader types.
+  (let loop ((i 0)
+             (fields+types fields+types))
+    (match fields+types
+      (() '())
+      (((name #(type size)) . rest)
+       (cons (list name i type size)
+             (loop (+ i 1) rest)))
+      (((name type) . rest)
+       (cons (list name i type 1)
+             (loop (+ i 1) rest))))))
+
+(define (display-shader-struct-instance obj port)
+  (let ((vtable (struct-vtable obj)))
+    (format port "#<~a" (shader-struct-name vtable))
+    (let loop ((fields (shader-struct-fields vtable)))
+      (match fields
+        (() #f)
+        (((name index type size) . rest)
+         (format port " ~a[~d ~a]: ~a"
+                 name size (shader-data-type-name type) (struct-ref obj index))
+         (loop rest))))
+    (display ">" port)))
+
+(define (make-display-name sym)
+  (let ((str (symbol->string sym)))
+    (if (and (string-prefix? "<" str)
+             (string-suffix? ">" str))
+        (substring str 1 (- (string-length str) 1))
+        str)))
+
+(define (make-shader-struct name fields+types)
+  (make-struct/no-tail <shader-struct>
+                       (make-struct-layout
+                        (string-concatenate
+                         (map (const "pw") fields+types)))
+                       display-shader-struct-instance
+                       (make-display-name name)
+                       (make-shader-struct-field-table fields+types)))
+
+(define (shader-struct-ref struct field)
+  (match (assq-ref (shader-struct-fields (struct-vtable struct)) field)
+    (#f
+     (error "unknown struct field" field))
+    ((index _ _)
+     (struct-ref struct index))))
+
+(define-syntax define-accessors
+  (syntax-rules ()
+    ((_ <struct> field getter)
+     (define getter
+       (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field)
+                      ((i _ _) i))))
+         (lambda (obj)
+           (struct-ref obj index)))))
+    ((_ <struct> field getter setter)
+     (begin
+       (define-accessors <struct> field getter)
+       (define setter
+         (let ((index (match (assq-ref (shader-struct-fields <struct>) 'field)
+                        ((i _ _) i))))
+           (lambda (obj value)
+             (shader-struct-type-check <struct> 'field value)
+             (struct-set! obj index value))))))))
+
+(define-syntax define-shader-type
+  (syntax-rules ()
+    ((_ <name> constructor predicate (field-type field-name . field-rest) ...)
+     (begin
+       (define <name>
+         (make-shader-struct '<name> (list (list 'field-name field-type) ...)))
+       (define* (constructor #:key (field-name (shader-struct-default <name> 'field-name)) ...)
+         (shader-struct-type-check <name> 'field-name field-name) ...
+         (make-struct/no-tail <name> field-name ...))
+       (define (predicate obj)
+         (and (struct? obj) (eq? (struct-vtable obj) <name>)))
+       (define-accessors <name> field-name . field-rest) ...))))
 
 
 ;;;
@@ -201,6 +382,7 @@
   ;; garbage creation.
   (scratch-pointer shader-scratch-pointer))
 
+;; Represents a single active uniform location in a shader program.
 (define-record-type <uniform>
   (make-uniform name location type size value)
   uniform?
@@ -210,6 +392,61 @@
   (size uniform-size)
   (value uniform-value %set-uniform-value!))
 
+;; variable name -> {uniform, namespace, uniform array} map
+(define-record-type <uniform-namespace>
+  (make-uniform-namespace name members)
+  uniform-namespace?
+  (name uniform-namespace-name)
+  (members uniform-namespace-members))
+
+(define (fresh-uniform-namespace name)
+  (make-uniform-namespace name (make-hash-table)))
+
+(define (uniform-namespace-set! namespace name value)
+  (hashq-set! (uniform-namespace-members namespace) name value))
+
+(define (uniform-namespace-ref namespace name)
+  (hashq-ref (uniform-namespace-members namespace) name))
+
+(define (uniform-namespace-ref-or-create-namespace namespace name)
+  (or (uniform-namespace-ref namespace name)
+      (let ((new-ns (fresh-uniform-namespace name)))
+        (uniform-namespace-set! namespace name new-ns)
+        new-ns)))
+
+(define (uniform-namespace-ref-or-create-array namespace name)
+  (or (uniform-namespace-ref namespace name)
+      (let ((new-arr (fresh-uniform-array name)))
+        (uniform-namespace-set! namespace name new-arr)
+        new-arr)))
+
+(define (uniform-namespace-for-each proc namespace)
+  (hash-for-each proc (uniform-namespace-members namespace)))
+
+;; variable name -> {uniform, namespace} map
+(define-record-type <uniform-array>
+  (make-uniform-array name namespaces size)
+  uniform-array?
+  (name uniform-array-name)
+  (namespaces uniform-array-namespaces)
+  (size uniform-array-size set-uniform-array-size!))
+
+(define (fresh-uniform-array name)
+  (make-uniform-array name (make-hash-table) 0))
+
+(define (uniform-array-namespace-ref array i)
+  (hashv-ref (uniform-array-namespaces array) i))
+
+(define (uniform-array-namespace-add! array i)
+  (let ((ns (fresh-uniform-namespace (uniform-array-name array))))
+    (hashv-set! (uniform-array-namespaces array) i ns)
+    (set-uniform-array-size! array (max (uniform-array-size array) (+ i 1)))
+    ns))
+
+(define (uniform-array-ref-or-create array i)
+  (or (uniform-array-namespace-ref array i)
+      (uniform-array-namespace-add! array i)))
+
 (define-record-type <attribute>
   (make-attribute name location type)
   attribute?
@@ -285,26 +522,83 @@ them into a GPU shader program."
       (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)
+     ((= 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 (parse-name name)
-    ;; Primitive array uniform names have a suffix of "[0]" that needs
-    ;; to be removed to produce the actual uniform variable name.
-    (if (string-suffix? "[0]" name)
-        (substring name 0 (- (string-length name) 3))
-        name))
+  (define (uniform-name->symbol name)
+    ;; array uniform names have a suffix like "[0]" that needs to be
+    ;; removed to produce the actual uniform variable name that our
+    ;; shader interface will recognize.
+    (string->symbol
+     (let ((i (string-contains name "[")))
+       (if i (substring name 0 i) name))))
+  (define (parse-array-index name)
+    (let* ((start (string-contains name "["))
+           (end (- (string-length name) 1)))
+      (and start (string->number (substring name (+ start 1) end)))))
+  (define (struct? name)
+    (string-contains name "."))
+  (define (namespace->alist table)
+    (hash-map->list
+     (lambda (key value)
+       (cons key
+             (cond
+              ((uniform-namespace? value)
+               (namespace->alist value))
+              ((uniform-array? value)
+               (hash-map->list (lambda (key value)
+                                 (cons key (namespace->alist value)))
+                               (uniform-array-namespaces value)))
+              (else
+               (list (uniform-location value)
+                     (shader-data-type-name (uniform-type value))
+                     (uniform-size value))))))
+     (uniform-namespace-members table)))
+  (define (parse-struct name uniform namespace)
+    ;; Deconstruct the uniform name to produce a path through the
+    ;; namespace tree, follow it to the end and add the uniform as a
+    ;; leaf node in the tree.
+    (let inner ((path (string-split name #\.))
+                (namespace namespace))
+      (match path
+        ;; Yay, we're done!
+        ((leaf)
+         (uniform-namespace-set! namespace (uniform-name->symbol leaf) uniform))
+        ((branch . rest)
+         (let ((new-name (uniform-name->symbol branch))
+               (index (parse-array-index branch)))
+           ;; If there is an index included in the branch name like
+           ;; "[1]" then that means we have a nested array of structs
+           ;; within the struct.  Otherwise, it's just a single nested
+           ;; struct.
+           (if index
+               (let ((new-namespace
+                      (uniform-array-ref-or-create
+                       (uniform-namespace-ref-or-create-array namespace
+                                                              new-name)
+                       index)))
+                 (inner rest new-namespace))
+               (let ((new-namespace
+                      (uniform-namespace-ref-or-create-namespace namespace
+                                                                 new-name)))
+                 (inner rest new-namespace))))))))
   (define (extract-uniforms id)
     (let ((total (uniform-count id))
-          (table (make-hash-table)))
+          (namespace (fresh-uniform-namespace "root")))
+      ;; OpenGL has an API for shader program introspection that we
+      ;; use to extract all active uniforms.  This uniform data must
+      ;; then be parsed and turned into a data structure that can be
+      ;; used to translate Scheme data (either primitives or compound
+      ;; structures) to the GPU when it comes time to actually render
+      ;; something with the shader.
       (let loop ((i 0)
                  (texture-unit 0)
                  (scratch-size 0))
@@ -324,21 +618,37 @@ them into a GPU shader program."
                      (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))))
-                (hash-set! table
-                           (parse-name name)
-                           (make-uniform name location type size default))
+                     (sampler? (eq? type sampler-2d))
+                     (default (cond
+                               (sampler?
+                                texture-unit)
+                               ((= size 1)
+                                (shader-data-type-null type))
+                               (else
+                                (make-vector size (shader-data-type-null type)))))
+                     (uniform (make-uniform name location type size default)))
+                (if (struct? name)
+                    ;; The complicated path: Parse struct name and
+                    ;; build a branch of a tree structure.
+                    (parse-struct name uniform namespace)
+                    ;; The easy path: A top-level primitive.
+                    (uniform-namespace-set! namespace
+                                            (uniform-name->symbol name)
+                                            uniform))
                 (loop (1+ i)
+                      ;; A sampler uniform uses up one texture unit,
+                      ;; so move on to the next one in that case.
                       (if sampler?
                           (1+ texture-unit)
                           texture-unit)
+                      ;; Ensure we have enough space to serialize the
+                      ;; largest bit of data we send to the shader.
                       (max scratch-size
                            (* size
                               (shader-data-type-size type))))))
-            (values table scratch-size)))))
+            (begin
+              (pretty-print (namespace->alist namespace))
+              (values namespace scratch-size))))))
   (define (attribute-count id)
     (let ((bv (make-u32vector 1)))
       (gl-get-programiv id
@@ -386,10 +696,10 @@ them into a GPU shader program."
     (gl-delete-shader fragment-id)
     (call-with-values
         (lambda () (extract-uniforms id))
-      (lambda (uniforms scratch-size)
+      (lambda (namespace scratch-size)
         (let ((scratch (make-bytevector scratch-size)))
           (gpu-guard
-           (%make-shader id (extract-attributes id) uniforms
+           (%make-shader id (extract-attributes id) namespace
                          scratch (bytevector->pointer scratch))))))))
 
 (define (load-shader vertex-source-file fragment-source-file)
@@ -413,16 +723,48 @@ shader program."
 
 (define (shader-uniform shader name)
   "Return the metadata for the uniform NAME in SHADER."
-  (let ((uniform (hash-ref (shader-uniforms shader) name)))
+  (let ((uniform (uniform-namespace-ref (shader-uniforms shader) name)))
     (or uniform (error "no such uniform" name))))
 
 (define (shader-uniform-set! shader uniform-name x)
-  (let* ((uniform (shader-uniform shader uniform-name))
-         (type (uniform-type uniform)))
-    (when (and (> (uniform-size uniform) 1)
-               (not (= (uniform-size uniform) (vector-length x))))
-      (error "vector size mismatch for uniform" uniform-name))
-    ;; TODO: Figure out a way to avoid unnecessary uniform updates.
-    (shader-data-type-serialize type (shader-scratch shader) x)
-    (shader-data-type-apply-uniform type (uniform-location uniform) 1 (shader-scratch-pointer shader))
-    (%set-uniform-value! uniform x)))
+  (define (traverse uniform value)
+    (cond
+     ;; A leaf node of the uniform tree representing a single uniform
+     ;; location as determined by OpenGL.
+     ((uniform? uniform)
+      (let ((type (uniform-type uniform)))
+        ;; A vector of a primitive type must be the exact size that
+        ;; the shader expects.
+        (when (and (> (uniform-size uniform) 1)
+                   (not (= (uniform-size uniform) (vector-length x))))
+          (error "vector size mismatch for uniform" uniform-name))
+        ;; TODO: Figure out a way to avoid unnecessary uniform
+        ;; updates.  Maybe UBOs would help address this?
+        (shader-data-type-serialize type (shader-scratch shader) value)
+        (shader-data-type-apply-uniform type (uniform-location uniform) 1
+                                        (shader-scratch-pointer shader))
+        (%set-uniform-value! uniform value)))
+     ;; A nested namespace indicates that this must be a struct.
+     ((uniform-namespace? uniform)
+      (if (shader-struct? value)
+          (uniform-namespace-for-each
+           (lambda (key uniform)
+             (traverse uniform (shader-struct-ref value key)))
+           uniform)
+          (error "expected shader struct" x)))
+     ;; A nested array namespace indicates that this must be an array
+     ;; of structs.
+     ((uniform-array? uniform)
+      (let ((size (uniform-array-size uniform)))
+        ;; Vector size must match what the shader expects.
+        (if (and (vector? value)
+                 (= size (vector-length value)))
+            (let loop ((i 0))
+              (when (< i size)
+                (traverse (uniform-array-namespace-ref uniform i)
+                          (vector-ref value i))))
+            (error "vector size mismatch for uniform"
+                   (uniform-array-name uniform)))))))
+  ;; Walk the uniform namespace tree until we get to a leaf node or
+  ;; nodes.
+  (traverse (shader-uniform shader uniform-name) x))