Add macro expansion and free variable annotation.

1 files changed, 239 insertions, 14 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 505c4b4..72500fc 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -17,8 +17,8 @@
 
 ;;; Commentary:
 ;;
-;; Seagull is a purely functional, statically typed, Scheme-like
-;; language that can be compiled to GLSL code.
+;; The Seagull shading language is a purely functional, statically
+;; typed, Scheme-like language that can be compiled to GLSL code.
 ;;
 ;; Notable features and restrictions:
 ;; - Vertex and fragment shader output
@@ -31,9 +31,10 @@
 ;;
 ;;; Code:
 (define-module (chickadee graphics seagull)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
-  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
   #:export (compile-seagull))
 
 ;; The Seagull compiler is designed as a series of source-to-source
@@ -43,23 +44,191 @@
 
 
 ;;;
-;;; Alpha conversion
+;;; Compiler helpers
 ;;;
 
+;; This is where we keep miscellaneous code that is useful for many
+;; stages of the compiler.
+
+(define (float? x)
+  (and (number? x) (inexact? x)))
+
+;; Immediate types are fundamental data types that need no
+;; compilation.
+(define (immediate? x)
+  (or (exact-integer? x)
+      (float? x)
+      (char? x)
+      (boolean? x)))
+
+(define (primitive-call? x)
+  (memq x '(+ - * / = < <= > >=)))
+
+
+;;;
+;;; Lexical environments
+;;;
+
+;; Environments keep track of the variables that are in scope of an
+;; expression.
+
+(define (empty-env)
+  '())
+
+(define &seagull-unbound-variable-error
+  (make-exception-type '&seagull-unbound-variable-error &error '(name)))
+
+(define make-seagull-unbound-variable-error
+  (record-constructor &seagull-unbound-variable-error))
+
+(define seagull-unbound-variable-name
+  (exception-accessor &seagull-unbound-variable-error
+                      (record-accessor &seagull-unbound-variable-error 'name)))
+
+(define (lookup name env)
+  (or (assq-ref env name)
+      (raise-exception
+       (make-exception
+        (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))))))
+
+(define (lookup-all names env)
+  (map (lambda (name) (lookup name env)) names))
+
+(define (extend-env name value env)
+  (alist-cons name value env))
+
+(define (compose-envs . envs)
+  (concatenate envs))
+
+(define (top-level-env)
+  (empty-env))
+
+
+;;;
+;;; Macro expansion and alpha conversion
+;;;
+
+;; Macro expansion converts convenient but non-primitive syntax forms
+;; (such as let*) into primitive syntax.  Seagull does not currently
+;; support user defined macros, just a set of built-ins.
+;;
 ;; Alpha conversion is the process of converting all the user defined
 ;; identifiers in a program to uniquely named identifiers.  This
 ;; process frees the compiler from having to worry about things like
 ;; '+' being a user defined variable that shadows the primitive
 ;; addition operation.
 
+(define unique-identifier-counter (make-parameter 0))
+
+(define (unique-identifier-number)
+  (let ((n (unique-identifier-counter)))
+    (unique-identifier-counter (+ n 1))
+    n))
+
+(define (unique-identifier)
+  (string->symbol
+   (format #f "V~a" (unique-identifier-number))))
+
+(define (alpha-convert names)
+  (define names* (map (lambda (_name) (unique-identifier)) names))
+  (fold extend-env (empty-env) names names*))
+
+(define (expand-list exps env)
+  (map (lambda (exp) (expand exp env)) exps))
+
+(define (expand-variable exp env)
+  ;; Replace original variable with alpha-converted name, but keep
+  ;; track of the original for showing the user error messages that
+  ;; make sense later.
+  `(var ,(lookup exp env) ,exp))
+
+(define (expand-if predicate consequent alternate env)
+  `(if ,(expand predicate env)
+       ,(expand consequent env)
+       ,(expand alternate env)))
+
+(define (expand-let names exps body env)
+  (if (null? names)
+      (expand body env)
+      (let* ((env* (compose-envs (alpha-convert names) env))
+             (bindings* (map list (lookup-all names env*) exps)))
+        `(let ,bindings* ,(expand body env*)))))
+
+(define (expand-let* bindings body env)
+  (match bindings
+    (() (expand body env))
+    ((binding . rest)
+     (expand `(let (,binding)
+                (let* ,rest ,body))
+             env))))
+
+(define (expand-lambda params body env)
+  (define env* (compose-envs (alpha-convert params) env))
+  (define params* (lookup-all params env*))
+  `(lambda ,params* ,(expand body env*)))
+
+(define (expand-primitive-call operator operands env)
+  `(primcall ,operator ,@(expand-list operands env)))
+
+(define (expand-call operator operands env)
+  `(call ,(expand operator env) ,@(expand-list operands env)))
+
+(define &seagull-syntax-error
+  (make-exception-type '&seagull-syntax-error &error '(form)))
+
+(define make-seagull-syntax-error
+  (record-constructor &seagull-syntax-error))
+
+(define seagull-syntax-form
+  (exception-accessor &seagull-syntax-error
+                      (record-accessor &seagull-syntax-error 'form)))
+
+(define (expand exp env)
+  (match exp
+    ;; Immediates and variables:
+    ((? immediate?)
+     exp)
+    ((? symbol?)
+     (expand-variable exp env))
+    ;; Primitive syntax forms:
+    (('if predicate consequent alternate)
+     (expand-if predicate consequent alternate env))
+    (('let (((? symbol? names) exps) ...) body)
+     (expand-let names exps body env))
+    (('lambda ((? symbol? params) ...) body)
+     (expand-lambda params body env))
+    ;; Macros:
+    (('let* (bindings ...) body)
+     (expand-let* bindings body env))
+    ;; Primitive calls:
+    (((? primitive-call? operator) args ...)
+     (expand-primitive-call operator args env))
+    ;; Function calls:
+    ((operator args ...)
+     (expand-call operator args env))
+    ;; Syntax error:
+    (_
+     (raise-exception
+      (make-exception
+       (make-seagull-syntax-error exp)
+       (make-exception-with-origin expand)
+       (make-exception-with-message "seagull: invalid syntax")
+       (make-exception-with-irritants (list exp)))))))
+
+(define (expand* exp)
+  (parameterize ((unique-identifier-counter 0))
+    (expand exp (top-level-env))))
+
 
 ;;;
-;;; Macro expansion
+;;; Function hoisting
 ;;;
 
-;; Macro expansion converts convenient but non-primitive syntax forms
-;; (such as let*) into primitive syntax.  Seagull does not currently
-;; support user defined macros, just a set of built-ins.
+;; Move all lambda bindings to the top-level.  As mentioned earlier,
+;; GLSL does not allow nested functions.
 
 
 ;;;
@@ -72,13 +241,69 @@
 ;; allow free variable references for top-level variables, such as
 ;; shader inputs and uniforms.
 
-
-;;;
-;;; Function hoisting
-;;;
+(define &seagull-scope-error
+  (make-exception-type '&seagull-scope-error &error '(variable)))
+
+(define make-seagull-scope-error
+  (record-constructor &seagull-scope-error))
+
+(define seagull-scope-variable
+  (exception-accessor &seagull-scope-error
+                      (record-accessor &seagull-scope-error 'variable)))
+
+(define (free-variables exp bound-vars top-level-vars)
+  (match exp
+    ((? immediate?) '())
+    (('var name original-name)
+     (cond
+      ((memq name bound-vars) ; bound vars are not free
+       '())
+      ((memq name top-level-vars) ; free top-level var
+       (list name))
+      (else
+       ;; Free variables that aren't top-level are not allowed because
+       ;; GLSL doesn't support closures.
+       (raise-exception
+        (make-exception
+         (make-seagull-scope-error original-name)
+         (make-exception-with-origin free-variables)
+         (make-exception-with-message
+          "seagull: free variable is not top-level")
+         (make-exception-with-irritants (list exp)))))))
+    (('if predicate consequent alternate)
+     (append (free-variables predicate bound-vars top-level-vars)
+             (free-variables consequent bound-vars top-level-vars)
+             (free-variables alternate bound-vars top-level-vars)))
+    (('let ((names _) ...) body)
+     (free-variables body (append names bound-vars) top-level-vars))
+    (('lambda (params ...) body)
+     (free-variables body (append params bound-vars) top-level-vars))
+    ((or ('primcall _ args ...)
+         ('call args ...))
+     (append-map (lambda (arg)
+                   (free-variables arg bound-vars top-level-vars))
+                 args))))
 
-;; Move all non-top-level lambda bindings to the top-level.  As
-;; mentioned earlier, GLSL does not allow nested functions.
+(define (annotate-free-variables exp)
+  (match exp
+    ((or (? immediate?)
+         ('var _ _))
+     exp)
+    (('if predicate consequent alternate)
+     `(if (annotate-free-variables predicate)
+          (annotate-free-variables consequent)
+          (annotate-free-variables alternate)))
+    (('let ((names exps) ...) body)
+     (define exps* (map annotate-free-variables exps))
+     `(let ,(map list names exps*) ,(annotate-free-variables body)))
+    (('lambda (params ...) body)
+     ;; TODO: Actually figure out top-level vars.
+     (define free-vars (free-variables body params '(+ - * /)))
+     `(lambda ,free-vars ,params ,(annotate-free-variables body)))
+    (('primcall operator args ...)
+     `(primcall ,operator ,@(map annotate-free-variables args)))
+    (('call args ...)
+     `(call ,@(map annotate-free-variables args)))))
 
 
 ;;;