summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-02-17 19:17:41 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commit4dacba609001572d4b62d9bc312f20f95ae1e858 (patch)
treea91d51f5ba1fdfd2389810930d09040e3fdcc415
parent31712743cae72f5ea43aad140cd2df4f1a385364 (diff)
Add begin form.
-rw-r--r--chickadee/graphics/seagull.scm84
1 files changed, 55 insertions, 29 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index c5452b0..733157b 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -25,23 +25,20 @@
;;
;; Features:
;; - Purely functional
-;; - Vertex and fragment shader output
-;; - Targets multiple GLSL versions
-;; - Type inference
+;; - Statically typed via type inference
;; - Lexical scoping
;; - Nested functions
;; - Multiple return values
+;; - Vertex and fragment shader output
+;; - Emits code for multiple GLSL versions
;;
;; Limitations:
-;; - No first-class functions
+;; - First-order functions
;; - No closures
;; - No recursion
;;
;; TODO:
;; - Loops
-;; - (define ...) form
-;; - struct field aliases (rgba for vec4, for example) maybe a bad idea??
-;; - Scheme shader type -> GLSL struct translation
;; - Dead code elimination (error when a uniform is eliminated)
;; - User defined structs
;; - Multiple GLSL versions
@@ -74,9 +71,16 @@
seagull-module-global-map))
;; The Seagull compiler is designed as a series of source-to-source
-;; program transformations in which each transformation pass results
-;; in a program that is one step closer to being directly emitted to
-;; GLSL code.
+;; program transformations (as described in "Compilation by Program
+;; Transformation" by Richard Kelsey) in which each transformation
+;; pass results in a program that is one step closer to being directly
+;; emitted to GLSL code.
+;;
+;; I wouldn't have been able to write this compiler without the
+;; fantastic "An Incremental Approach to Compiler Construction" paper
+;; by Abdulaziz Ghuloum that showed me that even a mere mortal could
+;; write a useful compiler. Thanks to Christine Lemmer Webber for
+;; pointing me to that paper.
;;;
@@ -179,7 +183,7 @@
(make-seagull-unbound-variable-error name)
(make-exception-with-origin lookup)
(make-exception-with-message "seagull: unbound variable")
- (make-exception-with-irritants (list name env))))))
+ (make-exception-with-irritants (list name (env-names env)))))))
(define (lookup* name env)
(assq-ref env name))
@@ -247,7 +251,7 @@
(exception-accessor &seagull-syntax-error
(record-accessor &seagull-syntax-error 'form)))
-(define (seagull-syntax-error exp msg origin)
+(define (seagull-syntax-error msg exp origin)
(raise-exception
(make-exception
(make-seagull-syntax-error exp)
@@ -291,7 +295,7 @@
(let* ((exps* (map (lambda (exp) (expand exp stage env)) exps))
(env* (compose-envs (alpha-convert names) env))
(bindings* (map list (lookup-all names env*) exps*)))
- `(let ,bindings* ,(expand body stage env*)))))
+ `(let ,bindings* ,(expand `(begin ,@body) stage env*)))))
(define (expand:let* bindings body stage env)
(match bindings
@@ -305,7 +309,7 @@
(define (expand:lambda params body stage env)
(define env* (compose-envs (alpha-convert params) env))
(define params* (lookup-all params env*))
- `(lambda ,params* ,(expand body stage env*)))
+ `(lambda ,params* ,(expand `(begin ,@body) stage env*)))
(define (expand:values exps stage env)
`(values ,@(expand:list exps stage env)))
@@ -334,6 +338,25 @@
(loop `(array-ref ,prev ,(expand j stage env))
rest)))))))
+(define (expand:begin definitions body stage env)
+ (define bindings
+ (map (match-lambda
+ (('define (proc-name (? symbol? params) ...) body)
+ (list proc-name (expand `(lambda ,params ,body) stage env)))
+ (('define (? symbol? var-name) val)
+ (list var-name (expand val stage env)))
+ (invalid
+ (seagull-syntax-error "invalid definition" invalid expand:begin)))
+ definitions))
+ (define names (map first bindings))
+ (define env* (compose-envs (alpha-convert names) env))
+ (let loop ((bindings bindings))
+ (match bindings
+ (()
+ (expand body stage env*))
+ (((name value) . rest)
+ `(let ((,(lookup name env*) ,value)) ,(loop rest))))))
+
;; Arithmetic operators, in true Lisp fashion, can accept many
;; arguments. + and * accept 0 or more. - and / accept one or more.
;; The expansion pass transforms all such expressions into binary
@@ -469,9 +492,9 @@
;; Primitive syntax forms:
(('if predicate consequent alternate)
(expand:if predicate consequent alternate stage env))
- (('let (((? symbol? names) exps) ...) body)
+ (('let (((? symbol? names) exps) ...) body ...)
(expand:let names exps body stage env))
- (('lambda ((? symbol? params) ...) body)
+ (('lambda ((? symbol? params) ...) body ...)
(expand:lambda params body stage env))
(('values exps ...)
(expand:values exps stage env))
@@ -485,6 +508,8 @@
(expand:-> exp members stage env))
(('@ exp indices ...)
(expand:@ exp indices stage env))
+ (('begin (and ('define _ ...) definitions) ... body)
+ (expand:begin definitions body stage env))
(('let* (bindings ...) body)
(expand:let* bindings body stage env))
(('+ args ...)
@@ -2269,9 +2294,9 @@
(define (vars->subs exp env)
(match exp
(('t ((? variable-type? tvar)) (? symbol? name))
- (let ((type (lookup* name env)))
- (if type
- (list (cons tvar type))
+ (let ((types (lookup* name env)))
+ (if types
+ (list (cons tvar (first types)))
'())))
((head . rest)
(delete-duplicates
@@ -2321,8 +2346,7 @@
(compose-envs env
(top-level-type-env stage)))))
(define subs*
- (compose-substitutions subs
- (vars->subs func env)))
+ (compose-substitutions subs (vars->subs func env)))
(define func*
(apply-substitutions-to-exp func subs*))
`(function ,name (t (,type*) ,func*)))
@@ -2733,16 +2757,17 @@
(define-syntax define-shader-stage
(lambda (x)
(syntax-case x ()
- ((_ name stage ((qualifier type var) ...) source)
+ ((_ name stage ((qualifier type var) ...) source ...)
(let* ((globals (group-by-qualifier
(syntax->datum
#'((qualifier type var) ...))))
(inputs (assq-ref globals 'inputs))
(outputs (assq-ref globals 'outputs))
- (uniforms (assq-ref globals 'uniforms)))
+ (uniforms (assq-ref globals 'uniforms))
+ (source* #'(begin source ...)))
(define-values (compiled global-map max-id)
(compile-seagull #:stage (syntax->datum #'stage)
- #:source (syntax->datum #'source)
+ #:source (syntax->datum source*)
#:inputs inputs
#:outputs outputs
#:uniforms uniforms))
@@ -2751,7 +2776,8 @@
(uniforms (datum->syntax x uniforms))
(compiled (datum->syntax x compiled))
(global-map (datum->syntax x global-map))
- (max-id (datum->syntax x max-id)))
+ (max-id (datum->syntax x max-id))
+ (source (datum->syntax x source*)))
#'(define name
(make-seagull-module #:stage 'stage
#:inputs (specs->globals 'inputs)
@@ -2762,11 +2788,11 @@
#:global-map 'global-map
#:max-id max-id))))))))
-(define-syntax-rule (define-vertex-shader name specs source)
- (define-shader-stage name vertex specs source))
+(define-syntax-rule (define-vertex-shader name specs source ...)
+ (define-shader-stage name vertex specs source ...))
-(define-syntax-rule (define-fragment-shader name specs source)
- (define-shader-stage name fragment specs source))
+(define-syntax-rule (define-fragment-shader name specs source ...)
+ (define-shader-stage name fragment specs source ...))
(define (vertex-outputs-match-fragment-inputs? vertex fragment)
(let ((fragment-inputs (seagull-module-inputs fragment)))