Add a compile-program function to compile and link programs into opengl

Compile all the defined shaders and programs at startup
Catch every errors and provide some restarts after properly cleaning up
half-way compiled stuffs

src/render/render.lisp

@@ -14,7 +14,7 @@
 
 (defun initialize (&optional argv)
   "Initialize the render module.
-Create an opengl context attach to a window."
+Create an opengl context attached to a window and initialize the shader system."
   (format t "Initialize Render module~%")
   (let ((title (get-command-line-option argv "--title" "Stoe"))
         (width (get-command-line-option-int argv "--width" 800))
@@ -28,12 +28,14 @@ Create an opengl context attach to a window."
                                              :minor gl-utils:*minor-version*)))
         (progn
           (setf *window* (glop:create-window title width height))
-          (gl-utils:initialize 0)))))
+          (gl-utils:initialize 0)))
+    (shader:compile-all-shaders)))
 
 (defun finalize ()
   "Finalize the render module.
 Destroy the opengl context and the related resources."
   (format t "Finalize Render module~%")
+  (shader:destroy-all-shaders)
   (glop:destroy-window *window*)
   (setf *window* nil))
 

src/render/shader/glsl-compiler.lisp

@@ -39,7 +39,7 @@
 
 (defun fix-name-convention (cl-name)
   "Convert a variable name in common-lisp convention to a glsl compliant name."
-  (substitute #\_ #\- cl-name))
+  (string-downcase (substitute #\_ #\- cl-name)))
 
 (defun compile-shader-variables (vars)
   (apply #'concatenate 'string

src/render/shader/shader.lisp

@@ -7,9 +7,22 @@
 (defpackage stoe.shader
   (:nicknames :shader)
   (:use :cl :utils)
-  (:export :defshader))
+  (:export :defshader
+           :defprogram
+           :compile-all-shaders
+           :destroy-all-shaders))
 (in-package :stoe.shader)
 
+(defpackage %stoe.shaders
+  (:documentation "Package used to hold the symbols for the shader programs defined by defprogram."))
+
+(defstruct program
+  (name "" :read-only t)
+  (stages nil :read-only t)
+  attribs
+  uniforms
+  gl-program)
+
 (defvar *shader-db* (make-hash-table :test 'eq)
   "The database containing all the shaders defined with `defshader'.")
 
@@ -19,4 +32,114 @@
 (defmacro defshader (name args &body body)
   "Define a new shader in common-lisp style.
 The shader will be compiled in shader language and added to the pool."
-  `(%defshader ',name ',args ',body))
+  `(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)))))
+
+(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)))