From 1c1862dd6dc51a95264ab2e06f77d7da091ce95e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Renaud=20Casenave-P=C3=A9r=C3=A9?= <renaud@casenave-pere.fr>
Date: Sun, 29 Mar 2015 19:02:59 +0200
Subject: [PATCH] Handle more operations and wrap in main function

Add handlers for infix operations (+ - * / %) and assignments.
Wrap the resulting code in a main function.
Prepare for the lambda-list processing
---
 src/render/shader/compiler.lisp |  2 +-
 src/render/shader/glsl.lisp     | 81 +++++++++++++++++++++++++--------
 src/render/shader/walker.lisp   |  2 +-
 3 files changed, 63 insertions(+), 22 deletions(-)

diff --git a/src/render/shader/compiler.lisp b/src/render/shader/compiler.lisp
index 877279e..f39c92c 100644
--- a/src/render/shader/compiler.lisp
+++ b/src/render/shader/compiler.lisp
@@ -13,7 +13,7 @@
 (in-package :stoe.shader.compiler)
 
 (defun %defshader (lambda-list body)
-  (let ((shader (glsl-compile (cons 'newshader (cons lambda-list body)))))
+  (let ((shader (glsl-compile lambda-list body)))
     shader))
 
 (defmacro defshader (name lambda-list &body body)
diff --git a/src/render/shader/glsl.lisp b/src/render/shader/glsl.lisp
index 9024258..3ce93c4 100644
--- a/src/render/shader/glsl.lisp
+++ b/src/render/shader/glsl.lisp
@@ -24,36 +24,77 @@
 (defvar *env* nil
   "A special variable used as a container for the macro environment.")
 
+(defvar *verbose* nil
+  "Configure the verbosity of the compiler.
+if non-nil, the dsl will be printed in comments together with the glsl code.")
+
+(defmacro noop-handler (body)
+  `(format nil "/* ~((~{~a~^ ~})~) */~%" ,body))
+
+(defhandler (declare block return-from catch load-time-value
+                     macrolet symbol-macrolet flet labels let*
+                     eval-when defun lambda tagbody setq function
+                     the go unwind-protect progv quote) (&rest body)
+  "Handle the unsupported keywords. For the time being,
+the forms comprised of these keywords will be printed in comments."
+  (noop-handler body))
+
 (defhandler newshader (newshader lambda-list &rest body)
+  (declare (ignore newshader lambda-list))
   (walk-list body))
 
+(defhandler (progn locally) (progn &rest body)
+  "Handle the progn special form."
+  (declare (ignore progn))
+  (format nil "~{~a;~%~}" (walk-list body)))
+
 (defhandler let (let bindings &rest body)
-  (let* ((names (loop for binding in bindings
-                   collect (safe-first binding)))
-         (symbol-macrolet-names (loop for name in names
-                                   when (nth-value 1 (macroexpand-1 name *env*))
-                                   collect name)))
-    (apply #'concatenate 'string
-           (append (loop for binding in bindings
-                      collect (format nil "~@[~vt~]~(~a ~a~)~@[ = ~a~];~%"
-                                      (when (> *current-indent* 0)
-                                        *current-indent*)
-                                      (second binding) (first binding)
-                                      (if (and (cddr binding)
-                                               (not (cdddr binding)))
-                                          (walk-1 (third binding))
-                                          (walk-list (cddr binding)))))
-                   (walk-list body)))))
+  "Handle the variables declaration special form."
+  (declare (ignore let))
+  (format nil "~{~a;~%~}~%~a"
+          (loop for binding in bindings
+             collect (format nil "~@[~vt~]~(~a~) ~(~a~)~@[ = ~(~a~)~]"
+                             (when (> *current-indent* 0)
+                               *current-indent*)
+                             (second binding) (first binding)
+                             (if (and (cddr binding)
+                                      (not (cdddr binding)))
+                                 (walk-1 (third binding))
+                                 (walk-list (cddr binding)))))
+          (format nil "~{~a;~%~}" (walk-list body))))
+
+(defhandler setf (setf &rest pairs)
+  "Handle the assignment special form."
+  (declare (ignore setf))
+  (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 n collect (walk-1 r))))
+      (format nil "~@[~vt~]~{~(~a~) = ~(~a~)~^;~%~}"
+              (when (> *current-indent* 0)
+                *current-indent*)
+              expanded))))
+
+(defhandler (+ - * / %) (op &rest body)
+  "Handle the standard infix operations."
+  (flet ((oper (a b)
+           (format nil "~a ~(~a~) ~a"
+                   (if (listp a) (format t "(~a)" (walk-1 a)) a) op
+                   (if (listp b) (format nil "(~a)" (walk-1 b)) b))))
+    (reduce #'oper body)))
 
 (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
               (walk-1 first)) (walk-list rest)))
 
-(defun glsl-compile (form)
-  (let ((*current-indent* 0))
-    (walk form *form-handlers* #'default-handler *env*)))
+(defun glsl-compile (lambda-list body)
+  (declare (ignore lambda-list))
+  (format nil "~%~a~%void main ()~%{~%~a}~%"
+
+          (let ((*current-indent* 2))
+            (walk `(progn ,body) *form-handlers* #'default-handler *env*))))
diff --git a/src/render/shader/walker.lisp b/src/render/shader/walker.lisp
index 1e5b774..ec0a4de 100644
--- a/src/render/shader/walker.lisp
+++ b/src/render/shader/walker.lisp
@@ -95,7 +95,7 @@
 
 (defmacro defhandler (symbol lambda-list &body body)
   (let ((syms (safe-list symbol)))
-    (let ((func (intern (format nil "~A~A" 'handler- (first syms)))))
+    (let ((func (intern (format nil "~a~a" 'handler- (first syms)))))
       `(progn
          (defun ,func ,lambda-list
            ,@body)