118 lines
4.2 KiB
Common Lisp
118 lines
4.2 KiB
Common Lisp
#|
|
|
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
|
|
(:use :cl :utils)
|
|
(:nicknames :glsl)
|
|
(:import-from :stoe.shader.walker
|
|
:defhandler
|
|
:walk
|
|
:walk-list
|
|
:walk-1)
|
|
(:export :compile))
|
|
(in-package :stoe.shader.glsl)
|
|
|
|
(defvar *form-handlers* (make-hash-table)
|
|
"Hash table for the form handlers for a glsl dsl.")
|
|
|
|
(defvar *current-indent* 0
|
|
"Keep the number of space needed for the next directive.")
|
|
|
|
(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.")
|
|
|
|
(defvar *glsl-symbols* '(gl-position "gl_Position")
|
|
"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)
|
|
(string-downcase (substitute #\_ #\- (symbol-name cl-name)))))
|
|
|
|
(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)
|
|
"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 (glsl-name 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."
|
|
(labels ((expand (a)
|
|
(cond
|
|
((listp a) (format nil "(~a)" (walk-1 a)))
|
|
((symbolp a) (glsl-name a))
|
|
(t a)))
|
|
(oper (a b)
|
|
(format nil "~a ~(~a~) ~a"
|
|
(expand a) op (expand b))))
|
|
(reduce #'oper body)))
|
|
|
|
(defun default-handler (first &rest rest)
|
|
"Handle a simple function call."
|
|
(format nil "~@[~vt~]~(~a~) (~{~(~a~)~^, ~})"
|
|
(when (> *current-indent* 0)
|
|
*current-indent*)
|
|
(if (symbolp first)
|
|
first
|
|
(walk-1 first)) (walk-list rest)))
|
|
|
|
(defun handle-preamble (form)
|
|
"Handle a preamble declaration."
|
|
(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))))
|
|
|
|
(defun glsl-compile (lambda-list body)
|
|
(format nil "~a~%~%~{~a~}~%void main ()~%{~%~a}~%"
|
|
(mapcar #'handle-preamble lambda-list)
|
|
(let ((*current-indent* 2))
|
|
(walk `(progn ,body) *form-handlers* #'default-handler *env*))))
|