Add <seagull-variable> type.

1 files changed, 125 insertions, 32 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 7a22355..d03de86 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -109,15 +109,6 @@
 (define (top-level-qualifier? x)
   (memq x '(in out uniform)))
 
-(define (built-in-output? name stage)
-  (case stage
-    ((vertex)
-     ;; GL 4+ has more built-ins, but we are supporting GL 2+ so we
-     ;; can't use them easily.
-     (memq name '(vertex:position vertex:point-size vertex:clip-distance)))
-    ((fragment)
-     (memq name '(vertex:frag-depth)))))
-
 
 ;;;
 ;;; Lexical environments
@@ -189,13 +180,6 @@
                (proc name exp)))
             env))
 
-(define (top-level-env stage)
-  (case stage
-    ((vertex)
-     (empty-env))
-    ((fragment)
-     '((fragment:coord . fragment:coord)))))
-
 
 ;;;
 ;;; Types
@@ -431,6 +415,98 @@
 
 
 ;;;
+;;; Built-in variables
+;;;
+
+(define-record-type <seagull-variable>
+  (%make-seagull-variable name glsl-name type stages qualifier)
+  seagull-variable?
+  (name seagull-variable-name)
+  (glsl-name seagull-variable-glsl-name)
+  (type seagull-variable-type)
+  (stages seagull-variable-stages)
+  (qualifier seagull-variable-qualifier))
+
+(define* (make-seagull-variable name #:key glsl-name type stages qualifier)
+  (%make-seagull-variable name glsl-name type stages qualifier))
+
+(define (output-variable? variable)
+  (eq? (seagull-variable-qualifier variable) 'output))
+
+(define (input-variable? variable)
+  (eq? (seagull-variable-qualifier variable) 'input))
+
+(define (variable-for-stage? variable stage)
+  (memq stage (seagull-variable-stages variable)))
+
+(define *seagull-variables* (make-hash-table))
+
+(define (register-seagull-variable! variable)
+  (hashq-set! *seagull-variables*
+              (seagull-variable-name variable)
+              variable))
+
+(define (find-variables pred)
+  (hash-fold (lambda (k v memo)
+               (if (pred v)
+                   (cons v memo)
+                   memo))
+             '()
+             *seagull-variables*))
+
+(define (lookup-output-variable name)
+  (let ((variable (hashq-ref *seagull-variables* name)))
+    (and (seagull-variable? variable)
+         (output-variable? variable)
+         variable)))
+
+(define (lookup-output-variable-for-stage name stage)
+  (let ((variable (lookup-output-variable name)))
+    (and (seagull-variable? variable)
+         (variable-for-stage? variable stage)
+         variable)))
+
+(define (lookup-input-variable name)
+  (let ((variable (hashq-ref *seagull-variables* name)))
+    (and (seagull-variable? variable)
+         (input-variable? variable)
+         variable)))
+
+(define-syntax-rule (define-seagull-variable name args ...)
+  (register-seagull-variable! (make-seagull-variable 'name args ...)))
+
+(define-seagull-variable vertex:position
+  #:glsl-name 'gl_Position
+  #:type type:vec4
+  #:stages '(vertex)
+  #:qualifier 'output)
+
+(define-seagull-variable vertex:point-size
+  #:glsl-name 'gl_PointSize
+  #:type type:float
+  #:stages '(vertex)
+  #:qualifier 'output)
+
+(define-seagull-variable vertex:clip-distance
+  #:glsl-name 'gl_ClipDistance
+  #:type type:float
+  #:stages '(vertex)
+  #:qualifier 'output)
+
+(define-seagull-variable fragment:depth
+  #:glsl-name 'gl_FragDepth
+  #:type type:float
+  #:stages '(fragment)
+  #:qualifier 'output)
+
+(define-seagull-variable fragment:coord
+  #:glsl-name 'gl_FragCoord
+  #:type type:vec4
+  #:stages '(fragment)
+  #:qualifier 'input)
+
+
+;;;
 ;;; Primitives
 ;;;
 
@@ -826,6 +902,16 @@
 (define (unique-identifiers-for-list lst)
   (map (lambda (_x) (unique-identifier)) lst))
 
+(define (top-level-env stage)
+  (fold (lambda (v env)
+          (let ((name (seagull-variable-name v)))
+            (extend-env name name env)))
+        (empty-env)
+        (find-variables
+         (lambda (v)
+           (and (input-variable? v)
+                (variable-for-stage? v stage))))))
+
 (define (alpha-convert names)
   (define names* (map (lambda (_name) (unique-identifier)) names))
   (fold extend-env (empty-env) names names*))
@@ -1016,10 +1102,13 @@
 (define (expand:outputs names exps stage env)
   `(outputs
     ,@(map (lambda (name exp)
-             (list (if (built-in-output? name stage)
-                       name
-                       (lookup name env))
-                   (expand exp stage env)))
+             (let ((variable (lookup-output-variable-for-stage name stage)))
+               (list (if (seagull-variable? variable)
+                         (seagull-variable-name variable)
+                         ;; TODO: Check that the variable is an output
+                         ;; variable.
+                         (lookup name env))
+                     (expand exp stage env))))
            names exps)))
 
 (define (expand:discard stage env)
@@ -1083,6 +1172,9 @@
     (_
      (seagull-syntax-error "unknown form" exp expand))))
 
+(define (expand* exp stage)
+  (expand exp stage (top-level-env stage)))
+
 
 ;;;
 ;;; Constant propagation and folding
@@ -2989,15 +3081,13 @@
   (emit-glsl body stage version port (+ level 1))
   (display "}\n" port))
 
-(define %built-in-output-map
-  '((vertex:position . gl_Position)
-    (vertex:point-size . gl_PointSize)
-    (vertex:clip-distance . gl_ClipDistance)
-    (fragment:depth . gl_FragDepth)))
+(define (glsl-output-name name)
+  (let ((variable (lookup-output-variable name)))
+    (if (seagull-variable? variable)
+        (seagull-variable-glsl-name variable)
+        name)))
 
 (define (emit:outputs names exps stage version port level)
-  (define (output-name name)
-    (or (assq-ref %built-in-output-map name) name))
   (if (and (eq? stage 'fragment) (null? names))
       (begin
         (indent level port)
@@ -3007,13 +3097,16 @@
                     ((temp)
                      (indent level port)
                      (format port "~a = ~a;\n"
-                             (output-name name)
+                             (glsl-output-name name)
                              temp))))
                 names exps))
   '(#f))
 
-(define %built-in-input-map
-  '((fragment:coord . gl_FragCoord)))
+(define (glsl-input-name name)
+  (let ((variable (lookup-input-variable name)))
+    (if (seagull-variable? variable)
+        (seagull-variable-glsl-name variable)
+        name)))
 
 (define* (emit-glsl exp stage version port #:optional (level 0))
   (match exp
@@ -3024,7 +3117,7 @@
     (('t _ (? boolean? b))
      (emit:boolean b stage version port level))
     (('t _ (? symbol? var))
-     (list (or (assq-ref %built-in-input-map var) var)))
+     (list (glsl-input-name var)))
     (('t _ ('if predicate consequent alternate))
      (emit:if predicate consequent alternate stage version port level))
     (('t _ ('values exps ...))
@@ -3111,7 +3204,7 @@
     (let ((source* `(top-level ,(append inputs outputs uniforms)
                                ,body)))
       (define-values (expanded global-map)
-        (expand source* stage (top-level-env stage)))
+        (expand* source* stage))
       (let* ((simplified (simplify-exp expanded (empty-env)))
              (pruned (prune simplified))
              (hoisted (hoist-functions* pruned))