Add begin form.

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)))