Implement a new shader definition system

Use a Domain Specific Language to define shaders in common-lisp syntax.
The code is then walked and compiled into glsl expressions and stored in
easy to use structures.

At the program initialization, the shader programs are compiled into opengl.

Dependencies are also kept, so that if a shader is redefined, the
corresponding program will be recompiled into opengl.

The old glsl-compiler is deleted as it is now rendered useless.

The render and mesh code are fixed according to changes in the interface.

src/render/mesh.lisp

@@ -11,7 +11,7 @@
 (in-package :stoe.render.mesh)
 
 (defstruct attrib
-  (name "")
+  (symb nil)
   type
   size
   offset)
@@ -42,12 +42,12 @@
         (buffer-size 0)
         (end-offset 0))
     (let* ((attribs (mapcar (lambda (attrib)
-                              (let ((name (first attrib))
+                              (let ((symb (first attrib))
                                     (type (second attrib))
                                     (size (third attrib))
                                     (buffer (fourth attrib)))
                                 (prog1
-                                    (make-attrib :name (symbol-name name) :type type
+                                    (make-attrib :symb (intern (symbol-name symb) :keyword) :type type
                                                  :size size :offset end-offset)
                                   (setf buffer-data (cons buffer buffer-data))
                                   (let ((len (length buffer)))

src/render/render.lisp

@@ -6,8 +6,7 @@
 (in-package :cl-user)
 (defpackage stoe.render
   (:nicknames :render)
-  (:use :cl
+  (:use :cl :utils :gl-utils :shader)
-        :utils)
   (:export :poll-events)
   (:import-from :modules
                 :defmodule)
@@ -49,14 +48,14 @@ Create an opengl context attached to a window and initialize the shader system."
         (progn
           (setf *window* (glop:create-window title width height))
           (gl-utils:initialize 0)))
-    (shader:compile-all-shaders))
+    (compile-all-shaders))
   (initialize-renderer))
 
 (defun finalize ()
   "Finalize the render module.
 Destroy the opengl context and the related resources."
   (format t "Finalize Render module~%")
-  (shader:destroy-all-shaders)
+  (destroy-all-shaders)
   (glop:destroy-window *window*)
   (setf *window* nil)
   (gl-utils:finalize))
@@ -80,7 +79,7 @@ This needs to be called once per frame, at the beginning of the loop."
     (glop:dispatch-events *window* :blocking nil :on-foo nil)))
 
 (defmethod glop:on-event (window event)
-  (declare (ignore window event))
+  (declare (ignore window))
   (typecase event
     (glop:key-press-event (input:on-key-event t (glop:keycode event) (glop:keysym event) (glop:text event)))
     (glop:key-release-event (input:on-key-event nil (glop:keycode event) (glop:keysym event) (glop:text event)))
@@ -101,8 +100,8 @@ This needs to be called once per frame, at the beginning of the loop."
 (defun render-mesh (node mesh)
   "Render a single mesh."
   (loop for stream in (mesh::mesh-streams mesh)
-     do (shader::using-program (program (mesh::mesh-stream-program stream))
+     do (using-program (program (mesh::mesh-stream-program stream))
-          (shader::with-uniforms (model-to-camera camera-to-clip) program
+          (with-locations (model-to-camera camera-to-clip) program
             (gl:uniform-matrix model-to-camera 4 (vector (m:* (view (get-current-camera))
                                                               (trans-mat node))))
             (gl:uniform-matrix camera-to-clip 4 (vector (proj (get-current-camera)))))
@@ -111,14 +110,15 @@ This needs to be called once per frame, at the beginning of the loop."
                  (attribs (mesh::vertex-buffer-attribs vertex-buffer)))
             (gl:bind-buffer :array-buffer (mesh::vertex-buffer-buffer-object vertex-buffer))
             (loop for attrib in attribs
-               do (let* ((attrib-name (mesh::attrib-name attrib))
+               do (let* ((attrib-name (mesh::attrib-symb attrib))
-                         (attrib-loc (shader::get-attrib-location program attrib-name)))
+                         (attrib-loc (get-location program attrib-name)))
-                    (gl-utils:gl-assert (gl:enable-vertex-attrib-array attrib-loc))
+                    (unless (= attrib-loc -1)
-                    (gl-utils:gl-assert (gl:vertex-attrib-pointer attrib-loc (mesh::attrib-size attrib)
+                      (gl-assert (gl:enable-vertex-attrib-array attrib-loc)
+                                 (gl:vertex-attrib-pointer attrib-loc (mesh::attrib-size attrib)
                                                            (mesh::attrib-type attrib) :false 0
-                                                                  (mesh::attrib-offset attrib)))))
+                                                           (mesh::attrib-offset attrib))))))
             (gl:bind-buffer :element-array-buffer (mesh::index-buffer-buffer-object index-buffer))
-            (gl-utils:gl-assert (%gl:draw-elements (mesh::index-buffer-mode index-buffer)
+            (gl-assert (%gl:draw-elements (mesh::index-buffer-mode index-buffer)
                                           (mesh::index-buffer-size index-buffer)
                                           (mesh::index-buffer-type index-buffer) 0))
             (gl:disable-vertex-attrib-array 0)

src/render/shader/compiler.lisp

@@ -1,25 +1,147 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
 (in-package :cl-user)
 (defpackage stoe.shader.compiler
-  (:use :cl :utils)
+  (:use :cl :utils :gl-utils :shader :glsl)
   (:nicknames :compiler)
-  (:import-from :stoe.shader.glsl
+  (:export :defshader
-                :glsl-compile)
+           :defprogram
-  (:export :defshader))
+           :compile-all-shaders
+           :destroy-all-shaders))
 (in-package :stoe.shader.compiler)
 
+(defvar *shaders-table* (make-hash-table))
+(defvar *programs-table* (make-hash-table))
+
 (defun %defshader (lambda-list body)
-  (let ((shader (glsl-compile lambda-list body)))
+  (glsl-compile lambda-list body))
-    shader))
 
 (defmacro defshader (name lambda-list &body body)
   "Define a shader defining function.
 The newly created shader will be put in a special package: `%stoe.shaders'."
-  (let ((symbol (intern (symbol-name name) :%stoe.shaders)))
   `(progn
-       (set ',symbol (%defshader ',lambda-list ',body))
+     (set ',name (%defshader ',lambda-list ',body))
-       ',symbol)))
+     (when (gl-initialized-p)
+       (mapc (lambda (program)
+               (delete-program program)
+               (compile-program program)) (gethash ',name *shaders-table*)))))
+
+(defun %defprogram (lambda-list body)
+  (make-program lambda-list body))
+
+(defun clean-dep (name shader-list)
+  (loop for shader in (cdr shader-list) by #'cddr
+        do (setf (gethash shader *shaders-table*)
+                 (delete name (gethash shader *shaders-table*)))))
+
+(defun add-dep (name shader-list)
+  (loop for shader in (cdr shader-list) by #'cddr
+        do (pushnew name (gethash shader *shaders-table*))))
+
+(defmacro defprogram (name lambda-list &body body)
+  "Define a new program comprised of all the specified shaders."
+  `(progn
+     (when (gethash ',name *programs-table*)
+       (clean-dep ',name (gethash ',name *programs-table*)))
+     (set ',name (%defprogram ',lambda-list ',body))
+     (setf (gethash ',name *programs-table*) ',body)
+     (add-dep ',name ',body)
+     (when (gl-initialized-p)
+       (compile-program ',name))))
+
+(defun compile-shader (type shader)
+  "Compile the shader into opengl."
+  (let ((shader-obj (gl-assert (gl:create-shader type))))
+    (when (= shader-obj 0)
+      (error "Couldn't create shader object."))
+    (handler-case
+        (progn
+          (gl-assert (gl:shader-source shader-obj (glsl-print shader))
+                     (gl:compile-shader shader-obj))
+          (unless (gl:get-shader shader-obj :compile-status)
+            (error "Compile failure in ~(~s~) shader:~%~a~%~2i~a~%" type
+                   (glsl-print shader) (gl:get-shader-info-log shader-obj)))
+          shader-obj)
+      (error (condition)
+        (gl:delete-shader shader-obj)
+        (error condition)))))
+
+(defun initialize-program (program)
+  "Initialize the program.
+Retrieve the attributes and uniform locations."
+  (flet ((retrieve-location (var)
+           (unless (member :location (var-qualifiers var))
+             (let ((target (var-target var)))
+               (setf (var-qualifiers var)
+                     (append (var-qualifiers var)
+                             (list :location (funcall (cond
+                                                        ((eq target :in) #'gl:get-attrib-location)
+                                                        ((eq target :uniform) #'gl:get-uniform-location))
+                                                      (program-id program)
+                                                      (var-name var)))))))))
+    (mapc #'retrieve-location (program-vars program))))
+
+(defun compile-program (symbol)
+  "Compile and link the program."
+  (loop
+     while (restart-case
+               (let ((program (symbol-value symbol))
+                     compiled-shaders)
+                 (unless program
+                   (error "The program ~s is undefined." symbol))
+                 (unwind-protect
+                      (progn
+                        (loop for type in (program-stages program) by #'cddr
+                           for shader in (cdr (program-stages program)) by #'cddr
+                              do (push (compile-shader type (symbol-value shader)) compiled-shaders))
+                        (let ((prog-id (gl-assert (gl:create-program))))
+                          (when (= prog-id 0)
+                            (error "Couldn't create program object."))
+                          (unwind-protect
+                               (progn
+                                 (mapc (lambda (shader) (gl-assert (gl:attach-shader prog-id shader)))
+                                       compiled-shaders)
+                                 (gl-assert (gl:link-program prog-id))
+                                 (unless (gl:get-program prog-id :link-status)
+                                   (error "Link failure in shader program ~s:~%~2i~a~%" symbol
+                                          (gl:get-program-info-log prog-id)))
+                                 (setf (program-id program) prog-id)
+                                 (initialize-program program))
+                            (mapc (lambda (shader) (gl:detach-shader prog-id shader))
+                                  (gl:get-attached-shaders prog-id)))))
+                   (mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders))
+                 nil)
+             (retry ()
+               :report (lambda (stream) (format stream "Retry compiling the shader program ~a."
+                                                        symbol))
+               t)
+             (give-up ()
+               :report (lambda (stream) (format stream "Give up on the shader program ~a."
+                                                symbol))
+               nil))))
+
+(defun delete-program (symbol)
+  "Delete the program."
+  (let ((program (symbol-value symbol)))
+    (when (program-id program)
+      (gl:delete-program (program-id program))
+      (setf (program-id program) nil))))
+
+(defun compile-all-shaders ()
+  "Compile and link all the shaders into opengl."
+  (loop-with-progress "Compiling shaders"
+     for symbol being the hash-key in *programs-table*
+     do (progn
+          (compile-program symbol)
+          progress-step)))
+
+(defun destroy-all-shaders ()
+  "Destroy the programs registered in opengl."
+  (loop-with-progress "Deleting shaders"
+     for symbol being the hash-key in *programs-table*
+     do (progn
+          (delete-program symbol)
+          progress-step)))

src/render/shader/glsl-compiler.lisp

@@ -1,92 +0,0 @@
-#|
-  This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
-|#
-
-(in-package :cl-user)
-(defpackage stoe.shader.glsl-compiler
-  (:nicknames :glsl-compiler)
-  (:use :cl :utils)
-  (:export :make-shader))
-(in-package :stoe.shader.glsl-compiler)
-
-(defvar +default-version+ '(330 :core))
-(defvar +profile-names+ '(:core :compatibility))
-(defvar +interpolation-qualifiers+ '(:flat :noperspective :smooth))
-
-(defstruct sh-version
-  (number 0 :read-only t)
-  (profile nil :read-only t))
-
-(defstruct sh-variable
-  (name "" :read-only t)
-  (type :int :read-only t)
-  (qualifier :in :read-only t)
-  (array 1 :read-only t)
-  (location nil :read-only t)
-  (interp nil :read-only t))
-
-(defstruct (shader (:constructor %make-shader))
-  (name "" :read-only t)
-  (version nil :read-only t)
-  (inputs nil :read-only t)
-  (outputs nil :read-only t)
-  (uniforms nil :read-only t)
-  (code "" :read-only t))
-
-(defun compile-shader-version (version)
-  (format nil "#version ~a~@[ ~(~a~)~]~%" (sh-version-number version) (sh-version-profile version)))
-
-(defun fix-name-convention (cl-name)
-  "Convert a variable name in common-lisp convention to a glsl compliant name."
-  (string-downcase (substitute #\_ #\- cl-name)))
-
-(defun compile-shader-variables (vars)
-  (apply #'concatenate 'string
-         (loop for var in vars
-            collect (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~)~[~;~:;[~:*~a]~];~%"
-                            (sh-variable-location var)
-                            (sh-variable-interp var)
-                            (sh-variable-qualifier var)
-                            (sh-variable-type var)
-                            (fix-name-convention (sh-variable-name var))
-                            (sh-variable-array var)))))
-
-(defun compile-shader-main (body)
-  (format nil "void main ()~%{~%~a~%}~%" body))
-
-(defun process-version (spec)
-  (make-sh-version :number (if (numberp (car spec)) (car spec) (car +default-version+))
-                   :profile (if (and (cdr spec) (member (cadr spec) +profile-names+))
-                                (cadr spec)
-                                (car +profile-names+))))
-
-(defun process-variable-1 (qualifier spec)
-  (make-sh-variable :name (symbol-name (car spec))
-                    :type (cadr spec)
-                    :qualifier qualifier
-                    :array (getf (cddr spec) :array 1)
-                    :location (getf (cddr spec) :location nil)
-                    :interp (safe-first (member (getf (cddr spec) :interp) +interpolation-qualifiers+))))
-
-(defun process-variables (qualifier specs)
-  (loop for spec in specs
-     collect (process-variable-1 qualifier spec)))
-
-(defun compile-shader (version inputs outputs uniforms body)
-  "Compile a shader's data into a string containing the shader in glsl."
-  (concatenate 'string
-               (compile-shader-version version)
-               (compile-shader-variables inputs)
-               (compile-shader-variables outputs)
-               (compile-shader-variables uniforms)
-               (compile-shader-main body)))
-
-(defun make-shader (name args body)
-  (let* ((version (process-version (safe-list (getf args :version))))
-         (inputs (process-variables :in (getf args :in)))
-         (outputs (process-variables :out (getf args :out)))
-         (uniforms (process-variables :uniform (getf args :uniform)))
-         (code (compile-shader version inputs outputs uniforms (safe-first body))))
-    (%make-shader :name (symbol-name name) :version version :inputs inputs
-                  :outputs outputs :uniforms uniforms :code code)))

src/render/shader/glsl.lisp

@@ -1,18 +1,13 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
 (in-package :cl-user)
 (defpackage stoe.shader.glsl
-  (:use :cl :utils)
+  (:use :cl :utils :walker :shader)
   (:nicknames :glsl)
-  (:import-from :stoe.shader.walker
+  (:export :glsl-compile :glsl-print))
-                :defhandler
-                :walk
-                :walk-list
-                :walk-1)
-  (:export :compile))
 (in-package :stoe.shader.glsl)
 
 (defvar *form-handlers* (make-hash-table)
@@ -28,16 +23,19 @@
   "Configure the verbosity of the compiler.
 if non-nil, the dsl will be printed in comments together with the glsl code.")
 
-(defvar *version-profiles* '(("1.30" . "#version 130
+(defvar *version-profiles* '((1.3 . "#version 130
-#extension ARB_explicit_attrib_location : require")
+// #extension ARB_explicit_attrib_location : require")
-                             ("3.30" . "#version 330 core")))
+                             (3.3 . "#version 330 core")
+                             (4.4 . "#version 440 core")))
 
-(defvar *glsl-symbols* '(gl-position "gl_Position")
+(defvar *glsl-symbols* '(:gl-position "gl_Position"
+                         :gl-fragcoord "gl_FragCoord"
+                         :gl-fragcolor "gl_FragColor")
   "Keep a table of reserved glsl symbols.")
 
 (defun glsl-name (cl-name)
   "Convert a variable name in common-lisp convention to a glsl compliant name."
-  (or (getf *glsl-symbols* cl-name)
+  (or (getf *glsl-symbols* (intern (symbol-name cl-name) :keyword))
       (string-downcase (substitute #\_ #\- (symbol-name cl-name)))))
 
 (defmacro noop-handler (body)
@@ -65,15 +63,15 @@ the forms comprised of these keywords will be printed in comments."
   (declare (ignore let))
   (format nil "~{~a;~%~}~%~a"
           (loop for binding in bindings
-             collect (format nil "~@[~vt~]~(~a~) ~(~a~)~@[ = ~(~a~)~]"
+             collect (format nil "~@[~vt~]~(~a~) ~a~@[ = ~a~]"
                              (when (> *current-indent* 0)
                                *current-indent*)
-                             (second binding) (first binding)
+                             (second binding) (glsl-name (first binding))
                              (if (and (cddr binding)
                                       (not (cdddr binding)))
                                  (walk-1 (third binding))
                                  (walk-list (cddr binding)))))
-          (format nil "~{~a;~%~}" (walk-list body))))
+          (format nil "~{~a~^;~%~}" (walk-list body))))
 
 (defhandler setf (setf &rest pairs)
   "Handle the assignment special form."
@@ -81,8 +79,10 @@ the forms comprised of these keywords will be printed in comments."
   (let ((vars (loop for s in pairs by #'cddr collect s)))
     (let ((expanded (loop for n in vars
                        for r in (rest pairs) by #'cddr
-                       collect (glsl-name n) collect (walk-1 r))))
+                       collect (glsl-name n) collect (if (symbolp r)
-      (format nil "~@[~vt~]~{~(~a~) = ~(~a~)~^;~%~}"
+                                                         (glsl-name r)
+                                                         (walk-1 r)))))
+      (format nil "~@[~vt~]~{~a = ~a~^;~%~}"
               (when (> *current-indent* 0)
                 *current-indent*)
               expanded))))
@@ -99,25 +99,56 @@ the forms comprised of these keywords will be printed in comments."
                    (expand a) op (expand b))))
     (reduce #'oper body)))
 
+(defhandler (x y z w xy xz xw
+               yz yw zw xyz yzw xyzw) (attribs &rest rest)
+  "Handle swizzle."
+  (let ((symbol (first rest)))
+    (format nil "~a.~(~a~)"
+            (if (symbolp symbol)
+                (glsl-name symbol)
+                (walk-list symbol))
+            attribs)))
+
 (defun default-handler (first &rest rest)
   "Handle a simple function call."
-  (format nil "~@[~vt~]~(~a~) (~{~(~a~)~^, ~})"
+  (format nil "~@[~vt~]~a (~{~a~^, ~})"
           (when (> *current-indent* 0)
             *current-indent*)
           (if (symbolp first)
-              first
+              (glsl-name first)
               (walk-1 first)) (walk-list rest)))
 
+(defun symbol-handler (sym)
+  "Handle a single symbol."
+  (glsl-name sym))
+
 (defun handle-preamble (form)
   "Handle a preamble declaration."
+  (make-var (intern (symbol-name (first form)) :keyword) (glsl-name (first form))
+            (second form) (cddr form)
             (format nil "~@[layout (location = ~a) ~]~@[~(~a~) ~]~(~a~) ~(~a~) ~(~a~);~%"
                     (awhen (member :location form) (cadr it))
                     (awhen (member :interp form) (cadr it))
-          (third form) (second form) (glsl-name (first form))))
+                    (third form) (second form) (glsl-name (first form)))))
 
 (defun glsl-compile (lambda-list body)
-  (format nil "~a~%~%~{~a~}~%void main ()~%{~%~a}~%"
+  "Compile the shader defined in BODY to glsl format.
-          (cdr (assoc gl-utils:*glsl-version* *version-profiles* :test #'equal))
+The forms contained in LAMBDA-LIST are used to define the global variables of
-          (mapcar #'handle-preamble lambda-list)
+the shader."
+  (merge-shaders (make-shader :version (cdr (assoc gl-utils:*glsl-version* *version-profiles*
+                                                   :test #'equal)))
+                 (flet ((merge-preamble (sh1 sh2)
+                          (merge-shaders sh1 (handle-preamble sh2))))
+                   (reduce #'merge-preamble (cons (handle-preamble (first lambda-list))
+                                                  (rest lambda-list))))
+                 (make-exp (format nil "void main ()~%{~%~a}~%"
                                    (let ((*current-indent* 2))
-            (walk (cons 'progn body) *form-handlers* #'default-handler *env*))))
+                                     (walk (cons 'progn body) *form-handlers* #'default-handler #'symbol-handler *env*))))))
+
+(defun glsl-print (shader)
+  "Returns a string containing the complete SHADER in glsl format."
+  (format nil "~@[~a~%~%~]~{~a~}~%~a"
+          (or (shader-version shader) (cdr (assoc gl-utils:*glsl-version* *version-profiles*
+                                                   :test #'equal)))
+          (loop for var in (shader-vars shader)
+               collect (var-exp var)) (shader-exp shader)))

src/render/shader/shader.lisp

@@ -1,182 +1,118 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
 (in-package :cl-user)
 (defpackage stoe.shader
   (:nicknames :shader)
-  (:use :cl :utils)
+  (:use :cl :utils :gl-utils)
-  (:export :defshader
+  (:export :make-shader
-           :defprogram
+           :make-var
-           :compile-all-shaders
+           :make-exp
-           :destroy-all-shaders))
+           :merge-shaders
+           :shader-version
+           :shader-vars
+           :shader-exp
+           :var-symb
+           :var-name
+           :var-qualifiers
+           :var-target
+           :var-exp
+           :make-program
+           :program-stages
+           :program-vars
+           :program-id
+           :get-location
+           :using-program
+           :with-locations))
 (in-package :stoe.shader)
 
-(defpackage %stoe.shaders
+(defstruct shader
-  (:documentation "Package used to hold the symbols for the shader programs defined by defprogram."))
+  "Structure containing the shader in glsl format together with metadata used to
+properly handle the shader."
+  (version nil)
+  (vars nil)
+  (exp ""))
 
-(defstruct program
+(defstruct (var (:constructor %make-var))
-  (name "" :read-only t)
+  "Structure containing the shader variable in glsl format together with its
+attributes to properly handle the variable."
+  (symb nil)
+  (name "")
+  (type :none)
+  (qualifiers nil)
+  (exp ""))
+
+(defun make-var (symb name type qualifiers exp)
+  "Creates and returns a new shader container to keep track of the variable
+defined by the arguments."
+  (make-shader :vars (list (%make-var :symb symb
+                                      :name name
+                                      :type type
+                                      :qualifiers qualifiers
+                                      :exp exp))))
+
+(defun var-target (var)
+  "Returns the target type of the variable. Either :in, :out or :uniform."
+  (first (member-if (lambda (x) (or (eq x :in)
+                                    (eq x :out)
+                                    (eq x :uniform)))
+                    (var-qualifiers var))))
+
+(defun make-exp (exp)
+  "Creates and returns a new shader container to keep track of the glsl
+expression."
+  (make-shader :exp exp))
+
+(defun merge-shaders (&rest shaders)
+  "Merges two or more shader containers and returns the result."
+  (labels ((sh-merge (sh1 sh2)
+             (make-shader :version (or (shader-version sh1) (shader-version sh2))
+                          :vars (append (shader-vars sh1) (shader-vars sh2))
+                          :exp (concatenate 'string (shader-exp sh1) (shader-exp sh2)))))
+    (reduce #'sh-merge shaders)))
+
+(defstruct (program (:constructor %make-program))
+  "Structure containing the symbols of the different stages' shaders and the
+associated in/out/uniform variables.
+If the program is compiled into glsl, it keeps track of the object id."
   (stages nil :read-only t)
-  attribs
+  vars
-  uniforms
+  id)
-  gl-program)
 
-(defvar *shader-db* (make-hash-table :test 'eq)
+(defun make-program (lambda-list stages)
-  "The database containing all the shaders defined with `defshader'.")
+  "Creates a new program by using and analyzing the specified shaders."
+  (declare (ignore lambda-list))
+  (%make-program :stages stages
+                 :vars (remove-duplicates
+                        (reduce #'append
+                                (loop for shader in (cdr stages) by #'cddr
+                                   collect (remove-if-not
+                                            (lambda (var)
+                                              (member-if (lambda (x) (or (eq x :in) (eq x :uniform)))
+                                                         (var-qualifiers var)))
+                                            (shader-vars (symbol-value shader))))))))
 
-(defun %defshader (name args body)
+(defun get-location (program var)
-  (setf (gethash name *shader-db*) (glsl-compiler:make-shader name args body)))
+  "Retrieve the location value of the variable in program."
-
+  (second (member :location (var-qualifiers (first (member (intern (symbol-name var) :keyword)
-(defmacro defshader (name args &body body)
+                                                           (program-vars program)
-  "Define a new shader in common-lisp style.
+                                                           :key #'var-symb))))))
-The shader will be compiled in shader language and added to the pool."
-  `(stoe.shader::%defshader ',name ',args ',body))
-
-(defun %defprogram (name args body)
-  (declare (ignore args))
-  (let ((components (mapcar #'(lambda (comp)
-                                (cons (first comp) (gethash (second comp) *shader-db*)))
-                            (group body 2))))
-    (make-program :name (symbol-name name) :stages components)))
-
-(defmacro defprogram (name args &body body)
-  "Define a new program comprised of all the specified shaders."
-  (let ((symbol (intern (symbol-name name) :%stoe.shaders)))
-    `(progn
-       (set ',symbol (stoe.shader::%defprogram ',symbol ',args ',body))
-       ',symbol)))
-
-(defun compile-shader (type shader)
-  "Compile the shader into opengl."
-  (let ((shader-obj (gl-utils:gl-assert (gl:create-shader type))))
-    (when (= shader-obj 0)
-      (error "Couldn't create shader object."))
-    (handler-case
-        (progn
-          (gl-utils:gl-assert (gl:shader-source shader-obj (glsl-compiler::shader-code shader))) ; Not great…
-          (gl-utils:gl-assert (gl:compile-shader shader-obj))
-          (unless (gl:get-shader shader-obj :compile-status)
-            (error "Compile failure in ~(~s~) shader:~%~2i~a~%" type (gl:get-shader-info-log shader-obj)))
-          shader-obj)
-      (error (condition)
-        (gl:delete-shader shader-obj)
-        (error condition)))))
-
-(defun initialize-program (program)
-  "Initialize the program.
-Retrieve the attributes and uniform locations."
-  (let* ((shader (cdr (first (program-stages program))))
-         (inputs (glsl-compiler::shader-inputs shader))
-         (uniforms (glsl-compiler::shader-uniforms shader)))
-    (labels ((get-var-with-location (var fun)
-               (list (glsl-compiler::sh-variable-name var)
-                     (glsl-compiler::sh-variable-type var)
-                     (glsl-compiler::sh-variable-array var)
-                     (aif (glsl-compiler::sh-variable-location var)
-                          it
-                          (apply fun (program-gl-program program) (list (glsl-compiler::fix-name-convention
-                                                                         (glsl-compiler::sh-variable-name var)))))))
-             (get-attrib (var)
-               (get-var-with-location var #'gl:get-attrib-location))
-             (get-uniforms (var)
-               (get-var-with-location var #'gl:get-uniform-location)))
-      (setf (program-attribs program) (mapcar #'get-attrib inputs))
-      (setf (program-uniforms program) (mapcar #'get-uniforms uniforms)))))
-
-(defun compile-program (program-symbol)
-  "Compile and link the program."
-  (loop
-     (restart-case
-         (return
-           (let ((program (symbol-value program-symbol)))
-             (unless program
-               (error "The program ~s is undefined." program-symbol))
-             (let (compiled-shaders)
-               (unwind-protect
-                    (progn
-                      (loop for shader in (program-stages program)
-                         do (push (compile-shader (car shader) (cdr shader)) compiled-shaders))
-                      (let ((program-obj (gl-utils:gl-assert (gl:create-program))))
-                        (when (= program-obj 0)
-                          (error "Couldn't create program object."))
-                        (unwind-protect
-                             (progn
-                               (mapc (lambda (shader) (gl-utils:gl-assert (gl:attach-shader program-obj shader)))
-                                     compiled-shaders)
-                               (gl-utils:gl-assert (gl:link-program program-obj))
-                               (unless (gl:get-program program-obj :link-status)
-                                 (error "Link failure in shader program ~s:~%~2i~a~%" program-symbol
-                                        (gl:get-program-info-log program-obj)))
-                               (setf (program-gl-program program) program-obj)
-                               (initialize-program program))
-                          (mapc (lambda (shader) (gl:detach-shader program-obj shader))
-                                (gl:get-attached-shaders program-obj)))))
-                 (mapc (lambda (shader) (gl:delete-shader shader)) compiled-shaders)))))
-       (retry () :report (lambda (stream) (format stream "Retry compiling the shader program ~S." program-symbol))))))
-
-(defun delete-program (program-symbol)
-  "Delete the program bound to PROGRAM-SYMBOL."
-  (let ((program (symbol-value program-symbol)))
-    (when (program-gl-program program)
-      (gl:delete-program (program-gl-program program)))))
-
-(defun compile-all-shaders ()
-  "Compile and link all the shaders into opengl."
-  (let ((cmp-message "Compiling shaders")
-        ;; Count the columns used by the progress message
-        ;; if it goes on for more than max-columns, continue on the next line
-        (max-columns 80))
-    (format t cmp-message)
-    (loop for i upfrom (length cmp-message)
-       for program-symbol being the symbol in :%stoe.shaders
-       do (progn
-            (when (> i max-columns)
-              (format t "~%")
-              (setf i 0))
-            (format t ".")
-            (compile-program program-symbol)))
-    (format t "~%")))
-
-(defun destroy-all-shaders ()
-  "Destroy the programs registered in opengl."
-  (format t "Deleting shaders")
-  (loop for program-symbol being the symbol in :%stoe.shaders
-     do (delete-program program-symbol)))
-
-(defun get-attrib-location (program symbol)
-  (fourth (first (member symbol (program-attribs program) :key #'car :test #'equal))))
 
 (defmacro using-program ((var program) &body body)
-  "Use the specified program and bind all its attributes and uniform for use in `body'."
+  "Use the specified program and bind all its attributes and uniforms for use in BODY."
-  `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :%stoe.shaders))))
+  `(let ((,var (symbol-value (find-symbol (symbol-name ,program) :stoe.render.shaders))))
-     (gl-utils:gl-assert (gl:use-program (program-gl-program ,var)))
+     (gl-assert (gl:use-program (program-id ,var)))
      ,@body
-     (gl-utils:gl-assert (gl:use-program 0))))
+     (gl-assert (gl:use-program 0))))
 
-(defmacro with-uniforms (vars program &body body)
+(defmacro with-locations (vars program &body body)
+  "Binds the programs uniforms into the corresponding symbols of vars, using the
+same syntax as `with-accessors'."
   `(let ,(mapcar (lambda (var)
                    (cond
-                     ((listp var) (list (first var)
+                     ((listp var) (list (first var) `(get-location ,program ',(second var))))
-                                        `(fourth (first (member (symbol-name ',(second var))
+                     ((symbolp var) (list var `(get-location ,program ',var)))))
-                                                                (program-uniforms ,program)
-                                                                :key #'car :test #'equal)))))
-                     ((symbolp var) (list var `(fourth (first (member (symbol-name ',var)
-                                                                      (program-uniforms ,program)
-                                                                      :key #'car :test #'equal)))))))
-                 vars)
-     ,@body))
-
-(defmacro with-attribs (vars program &body body)
-  `(let ,(mapcar (lambda (var)
-                   (cond
-                     ((listp var) (list (first var)
-                                        `(fourth (first (member (symbol-name ',(second var))
-                                                                (program-attribs ,program)
-                                                                :key #'car :test #'equal)))))
-                     ((symbolp var) (list var `(fourth (first (member (symbol-name ',var)
-                                                                      (program-attribs ,program)
-                                                                      :key #'car :test #'equal)))))))
                  vars)
      ,@body))

src/render/shader/walker.lisp

@@ -1,6 +1,6 @@
 #|
   This file is a part of stoe project.
-  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
 |#
 
 (in-package :cl-user)
@@ -18,14 +18,18 @@
     "A special variable containing the handlers for our dsl keywords."))
 
 (defvar *default-handler* nil
-  "A special variable containing the default handler used for unknown symbols.")
+  "A special variable containing the default handler used for unknown function symbols.")
+
+(defvar *symbol-handler* nil
+  "A special variable containing the default handler used for single symbols.")
 
 (defvar *env* nil
   "A special variable used as a container for the macro environment.")
 
 (defun form-handler (first)
   "Retreive the handler for the symbol FIRST."
-  (gethash first *form-handlers* *default-handler*))
+  (gethash (intern (symbol-name first) :keyword)
+           *form-handlers* *default-handler*))
 
 (defun binding-to-symbol (binding)
   (let ((name (safe-first binding)))
@@ -65,7 +69,8 @@
   "Walk across the specified form."
   (flet ((handle (form)
            (apply (form-handler (first form)) form)))
-    (cond ((and (listp form) (gethash (first form) *form-handlers*))
+    (cond ((and (listp form) (gethash (intern (symbol-name (first form)) :keyword)
+                                      *form-handlers*))
            (handle form))
           (t
            (multiple-value-bind (form expanded)
@@ -80,6 +85,7 @@
                          (if (eq form next)
                              (handle form)
                              (walk-1 next))))
+                      (symbol (apply *symbol-handler* form))
                       (t
                        form)))))))))
 
@@ -100,12 +106,16 @@
          (defun ,func ,lambda-list
            ,@body)
          (setf ,@(loop for sym in syms
-                    collect `(gethash ',sym ,(intern (symbol-name '*form-handlers*)))
+                       collect `(gethash ,(intern (symbol-name sym) :keyword)
+                                         ,(intern (symbol-name '*form-handlers*)))
                        collect `',func))))))
 
-(defun walk (form handlers default-handler env)
+(defun walk (form handlers default-handler symbol-handler env)
-  "Walk the sexp FORM and transform it according to the rules defined in HANDLERS."
+  "Walk the sexp FORM and transform it according to the rules defined in HANDLERS.
+When no known symbol is parsed, it is either handled by DEFAULT-HANDLER or by SYMBOL-HANDLER,
+whether it is the first symbol of a form or just a single symbol."
   (let ((*form-handlers* handlers)
         (*default-handler* default-handler)
+        (*symbol-handler* symbol-handler)
         (*env* env))
     (walk-1 form)))

src/render/shaders.lisp

@@ -6,24 +6,20 @@
 (in-package :cl-user)
 (defpackage stoe.render.shaders
   (:nicknames :shaders)
-  (:use :cl
+  (:use :stoe.shader.compiler))
-        :shader))
 (in-package :stoe.render.shaders)
 
-(defshader simple-vertex (:version 330
+(defshader simple-vertex ((position :vec4 :in)
-                                   :in ((position :vec4 :location 0)
+                          (color :vec4 :in)
-                                        (color :vec4 :location 1))
+                          (out-color :vec4 :out :interp :smooth)
-                                   :out ((out-color :vec4 :interp :smooth))
+                          (camera-to-clip :mat4 :uniform)
-                                   :uniform ((camera-to-clip :mat4)
+                          (model-to-camera :mat4 :uniform))
-                                             (model-to-camera :mat4))
+  (setf gl-position (* camera-to-clip model-to-camera position)
-                                   )
+        out-color color))
-  "gl_Position = camera_to_clip * model_to_camera * position;
-out_color = color;")
 
-(defshader simple-fragment (:version 330
+(defshader simple-fragment ((out-color :vec4 :in :interp :smooth)
-                                     :in ((out-color :vec4))
+                            (frag-color :vec4 :out))
-                                     :out ((frag-color :vec4)))
+  (setf frag-color out-color))
-  "frag_color = out_color;")
 
 (defprogram simple-shader ()
   :vertex-shader simple-vertex

stoe.asd

@@ -59,11 +59,10 @@
                           ((:file "gl-utils")
                            (:module "shader"
                                     :components
-                                    ((:file "walker")
+                                    ((:file "shader")
+                                     (:file "walker")
                                      (:file "glsl")
-                                     (:file "compiler")
+                                     (:file "compiler")))
-                                     (:file "glsl-compiler")
-                                     (:file "shader")))
                            (:file "mesh")
                            (:file "render")
                            (:file "shaders"))